[multiple changes]
2012-07-23 Ed Schonberg <schonberg@adacore.com> * par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply to a formal object of an anonymous access type. 2012-07-23 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Try_Container_Indexing): A user-defined indexing aspect can have more than one index, e.g. to describe indexing of a multidimensional object. 2012-07-23 Hristian Kirtchev <kirtchev@adacore.com> * exp_ch4.adb (Apply_Accessibility_Check): Reimplemented. The check is now more complex and contains optional finalization part and mandatory deallocation part. 2012-07-23 Gary Dismukes <dismukes@adacore.com> * a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb, a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress Accessibility_Check for Element_Type allocators. 2012-07-23 Vasiliy Fofanov <fofanov@adacore.com> * projects.texi: Fix typo. 2012-07-23 Ed Schonberg <schonberg@adacore.com> * sem_res.adb (Resolve_Explicit_Derenference): If prefix is overloaded, remove those interpretations whose designated type does not match the context, to avoid spurious ambiguities that may be caused by the Ada 2012 conversion rule for anonymous access types. From-SVN: r189774
This commit is contained in:
Arnaud Charlet
parent
473e20df28
commit
5087840447
@ -1,3 +1,38 @@
|
||||
2012-07-23 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* par-ch6.adb (P_Mode): in Ada 2005, a mode indicator can apply
|
||||
to a formal object of an anonymous access type.
|
||||
|
||||
2012-07-23 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Try_Container_Indexing): A user-defined indexing
|
||||
aspect can have more than one index, e.g. to describe indexing
|
||||
of a multidimensional object.
|
||||
|
||||
2012-07-23 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* exp_ch4.adb (Apply_Accessibility_Check): Reimplemented. The check is
|
||||
now more complex and contains optional finalization part and mandatory
|
||||
deallocation part.
|
||||
|
||||
2012-07-23 Gary Dismukes <dismukes@adacore.com>
|
||||
|
||||
* a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb,
|
||||
a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress
|
||||
Accessibility_Check for Element_Type allocators.
|
||||
|
||||
2012-07-23 Vasiliy Fofanov <fofanov@adacore.com>
|
||||
|
||||
* projects.texi: Fix typo.
|
||||
|
||||
2012-07-23 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_res.adb (Resolve_Explicit_Derenference): If prefix is
|
||||
overloaded, remove those interpretations whose designated type
|
||||
does not match the context, to avoid spurious ambiguities that
|
||||
may be caused by the Ada 2012 conversion rule for anonymous
|
||||
access types.
|
||||
|
||||
2012-07-23 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* g-spitbo.adb (Substr (String)): Return full string and do not
|
||||
|
||||
@ -888,6 +888,13 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
|
||||
end if;
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
||||
-- allocator in the loop below, because the one in this block would
|
||||
-- have failed already.
|
||||
|
||||
Element : Element_Access := new Element_Type'(New_Item);
|
||||
begin
|
||||
New_Node := new Node_Type'(Element, null, null);
|
||||
@ -1461,8 +1468,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
|
||||
pragma Assert (Vet (Position), "bad cursor in Replace_Element");
|
||||
|
||||
declare
|
||||
X : Element_Access := Position.Node.Element;
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
|
||||
X : Element_Access := Position.Node.Element;
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
Free (X);
|
||||
|
||||
@ -694,6 +694,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
|
||||
|
||||
Position.Node.Key := new Key_Type'(Key);
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
exception
|
||||
@ -731,6 +736,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
|
||||
K : Key_Access := new Key_Type'(Key);
|
||||
E : Element_Access;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
|
||||
begin
|
||||
E := new Element_Type'(New_Item);
|
||||
return new Node_Type'(K, E, Next);
|
||||
@ -1166,6 +1176,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
|
||||
|
||||
Node.Key := new Key_Type'(Key);
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
exception
|
||||
@ -1215,6 +1230,10 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
|
||||
declare
|
||||
X : Element_Access := Position.Node.Element;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
|
||||
@ -185,6 +185,11 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
|
||||
|
||||
procedure Assign (Node : Node_Access; Item : Element_Type) is
|
||||
X : Element_Access := Node.Element;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case the
|
||||
-- actual type is class-wide or has access discriminants (RM 4.8(10.1)
|
||||
-- and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
@ -807,7 +812,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
|
||||
|
||||
X := Position.Node.Element;
|
||||
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
Free_Element (X);
|
||||
end if;
|
||||
@ -863,6 +875,11 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
|
||||
--------------
|
||||
|
||||
function New_Node (Next : Node_Access) return Node_Access is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
|
||||
Element : Element_Access := new Element_Type'(New_Item);
|
||||
begin
|
||||
return new Node_Type'(Element, Next);
|
||||
@ -1317,7 +1334,14 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
|
||||
|
||||
X := Node.Element;
|
||||
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
Free_Element (X);
|
||||
end Replace;
|
||||
|
||||
@ -291,7 +291,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
|
||||
with "attempt to tamper with cursors (tree is busy)";
|
||||
end if;
|
||||
|
||||
Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
||||
-- allocator in the loop below, because the one in this block would
|
||||
-- have failed already.
|
||||
begin
|
||||
Element := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
First := new Tree_Node_Type'(Parent => Parent.Node,
|
||||
Element => Element,
|
||||
others => <>);
|
||||
@ -1240,7 +1250,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
|
||||
|
||||
Position.Container := Parent.Container;
|
||||
|
||||
Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
||||
-- allocator in the loop below, because the one in this block would
|
||||
-- have failed already.
|
||||
begin
|
||||
Element := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
Position.Node := new Tree_Node_Type'(Parent => Parent.Node,
|
||||
Element => Element,
|
||||
others => <>);
|
||||
@ -1805,7 +1825,17 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
|
||||
with "attempt to tamper with cursors (tree is busy)";
|
||||
end if;
|
||||
|
||||
Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
|
||||
-- allocator in the loop below, because the one in this block would
|
||||
-- have failed already.
|
||||
begin
|
||||
Element := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
First := new Tree_Node_Type'(Parent => Parent.Node,
|
||||
Element => Element,
|
||||
others => <>);
|
||||
@ -2163,7 +2193,14 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
|
||||
with "attempt to tamper with elements (tree is locked)";
|
||||
end if;
|
||||
|
||||
E := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
E := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
X := Position.Node.Element;
|
||||
Position.Node.Element := E;
|
||||
|
||||
@ -812,6 +812,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
|
||||
|
||||
Position.Node.Key := new Key_Type'(Key);
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
exception
|
||||
@ -852,6 +857,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
|
||||
function New_Node return Node_Access is
|
||||
Node : Node_Access := new Node_Type;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Key := new Key_Type'(Key);
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
@ -1492,6 +1501,11 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
|
||||
|
||||
Node.Key := new Key_Type'(Key);
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
exception
|
||||
@ -1542,6 +1556,10 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
|
||||
declare
|
||||
X : Element_Access := Position.Node.Element;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2004-2012, 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- --
|
||||
@ -1167,6 +1167,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
|
||||
--------------
|
||||
|
||||
function New_Node return Node_Access is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
|
||||
Element : Element_Access := new Element_Type'(New_Item);
|
||||
|
||||
begin
|
||||
@ -1768,6 +1773,11 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
|
||||
|
||||
declare
|
||||
X : Element_Access := Node.Element;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
@ -1793,6 +1803,10 @@ package body Ada.Containers.Indefinite_Ordered_Multisets is
|
||||
--------------
|
||||
|
||||
function New_Node return Node_Access is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item); -- OK if fails
|
||||
Node.Color := Red_Black_Trees.Red;
|
||||
|
||||
@ -1173,9 +1173,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
"attempt to tamper with elements (set is locked)";
|
||||
end if;
|
||||
|
||||
X := Position.Node.Element;
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
X := Position.Node.Element;
|
||||
Position.Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
end;
|
||||
end if;
|
||||
end Include;
|
||||
|
||||
@ -1238,6 +1245,11 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
--------------
|
||||
|
||||
function New_Node return Node_Access is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
|
||||
Element : Element_Access := new Element_Type'(New_Item);
|
||||
|
||||
begin
|
||||
@ -1818,9 +1830,16 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
"attempt to tamper with elements (set is locked)";
|
||||
end if;
|
||||
|
||||
X := Node.Element;
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
X := Node.Element;
|
||||
Node.Element := new Element_Type'(New_Item);
|
||||
Free_Element (X);
|
||||
end;
|
||||
end Replace;
|
||||
|
||||
---------------------
|
||||
@ -1854,6 +1873,10 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
--------------
|
||||
|
||||
function New_Node return Node_Access is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- the actual type is class-wide or has access discriminants (see
|
||||
-- RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item); -- OK if fails
|
||||
Node.Color := Red;
|
||||
@ -1883,8 +1906,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
"attempt to tamper with elements (set is locked)";
|
||||
end if;
|
||||
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
end;
|
||||
|
||||
return;
|
||||
end if;
|
||||
@ -1901,8 +1931,15 @@ package body Ada.Containers.Indefinite_Ordered_Sets is
|
||||
"attempt to tamper with elements (set is locked)";
|
||||
end if;
|
||||
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Node.Element := new Element_Type'(Item);
|
||||
Free_Element (X);
|
||||
end;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
@ -2,11 +2,11 @@
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
|
||||
-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2011, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2012, 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- --
|
||||
@ -220,8 +220,17 @@ package body Ada.Containers.Indefinite_Holders is
|
||||
raise Program_Error with "attempt to tamper with elements";
|
||||
end if;
|
||||
|
||||
Free (Container.Element);
|
||||
Container.Element := new Element_Type'(New_Item);
|
||||
declare
|
||||
X : Element_Access := Container.Element;
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- Element allocator may need an accessibility check in case actual
|
||||
-- type is class-wide or has access discriminants (RM 4.8(10.1) and
|
||||
-- AI12-0035).
|
||||
begin
|
||||
Container.Element := new Element_Type'(New_Item);
|
||||
Free (X);
|
||||
end;
|
||||
end Replace_Element;
|
||||
|
||||
---------------
|
||||
@ -229,6 +238,10 @@ package body Ada.Containers.Indefinite_Holders is
|
||||
---------------
|
||||
|
||||
function To_Holder (New_Item : Element_Type) return Holder is
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case the
|
||||
-- actual type is class-wide or has access discriminants (RM 4.8(10.1)
|
||||
-- and AI12-0035).
|
||||
begin
|
||||
return (AF.Controlled with new Element_Type'(New_Item), 0);
|
||||
end To_Holder;
|
||||
|
||||
@ -1698,7 +1698,14 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
-- value, in case the allocation fails (either because there is no
|
||||
-- storage available, or because element initialization fails).
|
||||
|
||||
Container.Elements.EA (Idx) := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the
|
||||
-- case actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Container.Elements.EA (Idx) := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
-- The allocation of the element succeeded, so it is now safe to
|
||||
-- update the Last index, restoring container invariants.
|
||||
@ -1744,7 +1751,14 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
-- because there is no storage available, or because element
|
||||
-- initialization fails).
|
||||
|
||||
E (Idx) := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check
|
||||
-- in case the actual type is class-wide or has access
|
||||
-- discriminants (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
E (Idx) := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
-- The allocation of the element succeeded, so it is now
|
||||
-- safe to update the Last index, restoring container
|
||||
@ -1780,6 +1794,11 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
-- K always has a value if the exception handler triggers.
|
||||
|
||||
K := Before;
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in
|
||||
-- the case the actual type is class-wide or has access
|
||||
-- discriminants (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
while K < Index loop
|
||||
E (K) := new Element_Type'(New_Item);
|
||||
@ -1885,7 +1904,14 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
-- because there is no storage available, or because element
|
||||
-- initialization fails).
|
||||
|
||||
Dst.EA (Idx) := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in
|
||||
-- the case the actual type is class-wide or has access
|
||||
-- discriminants (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Dst.EA (Idx) := new Element_Type'(New_Item);
|
||||
end;
|
||||
|
||||
-- The allocation of the element succeeded, so it is now safe
|
||||
-- to update the Last index, restoring container invariants.
|
||||
@ -1925,7 +1951,14 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
-- already been updated), so if this allocation fails we simply
|
||||
-- let it propagate.
|
||||
|
||||
Dst.EA (Idx) := new Element_Type'(New_Item);
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in
|
||||
-- the case the actual type is class-wide or has access
|
||||
-- discriminants (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Dst.EA (Idx) := new Element_Type'(New_Item);
|
||||
end;
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
@ -3174,6 +3207,11 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
|
||||
declare
|
||||
X : Element_Access := Container.Elements.EA (Index);
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- where the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Container.Elements.EA (Index) := new Element_Type'(New_Item);
|
||||
Free (X);
|
||||
@ -3205,6 +3243,11 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
|
||||
declare
|
||||
X : Element_Access := Container.Elements.EA (Position.Index);
|
||||
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- where the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
|
||||
Free (X);
|
||||
@ -3949,6 +3992,11 @@ package body Ada.Containers.Indefinite_Vectors is
|
||||
|
||||
Last := Index_Type'First;
|
||||
|
||||
declare
|
||||
pragma Unsuppress (Accessibility_Check);
|
||||
-- The element allocator may need an accessibility check in the case
|
||||
-- where the actual type is class-wide or has access discriminants
|
||||
-- (see RM 4.8(10.1) and AI12-0035).
|
||||
begin
|
||||
loop
|
||||
Elements.EA (Last) := new Element_Type'(New_Item);
|
||||
|
||||
@ -659,7 +659,7 @@ package body Exp_Ch4 is
|
||||
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
|
||||
-- type, generate an accessibility check to verify that the level of the
|
||||
-- type of the created object is not deeper than the level of the access
|
||||
-- type. If the type of the qualified expression is class- wide, then
|
||||
-- type. If the type of the qualified expression is class-wide, then
|
||||
-- always generate the check (except in the case where it is known to be
|
||||
-- unnecessary, see comment below). Otherwise, only generate the check
|
||||
-- if the level of the qualified expression type is statically deeper
|
||||
@ -690,7 +690,11 @@ package body Exp_Ch4 is
|
||||
(Ref : Node_Id;
|
||||
Built_In_Place : Boolean := False)
|
||||
is
|
||||
New_Node : Node_Id;
|
||||
Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
|
||||
Cond : Node_Id;
|
||||
Free_Stmt : Node_Id;
|
||||
Obj_Ref : Node_Id;
|
||||
Stmts : List_Id;
|
||||
|
||||
begin
|
||||
if Ada_Version >= Ada_2005
|
||||
@ -701,6 +705,8 @@ package body Exp_Ch4 is
|
||||
or else
|
||||
(Is_Class_Wide_Type (Etype (Exp))
|
||||
and then Scope (PtrT) /= Current_Scope))
|
||||
and then
|
||||
(Tagged_Type_Expansion or else VM_Target /= No_VM)
|
||||
then
|
||||
-- If the allocator was built in place, Ref is already a reference
|
||||
-- to the access object initialized to the result of the allocator
|
||||
@ -712,39 +718,109 @@ package body Exp_Ch4 is
|
||||
|
||||
if Built_In_Place then
|
||||
Remove_Side_Effects (Ref);
|
||||
New_Node := New_Copy (Ref);
|
||||
Obj_Ref := New_Copy (Ref);
|
||||
else
|
||||
New_Node := New_Reference_To (Ref, Loc);
|
||||
Obj_Ref := New_Reference_To (Ref, Loc);
|
||||
end if;
|
||||
|
||||
New_Node :=
|
||||
-- Step 1: Create the object clean up code
|
||||
|
||||
Stmts := New_List;
|
||||
|
||||
-- Create an explicit free statement to clean up the allocated
|
||||
-- object in case the accessibility check fails. Generate:
|
||||
|
||||
-- Free (Obj_Ref);
|
||||
|
||||
Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
|
||||
Set_Storage_Pool (Free_Stmt, Pool_Id);
|
||||
|
||||
Append_To (Stmts, Free_Stmt);
|
||||
|
||||
-- Finalize the object (if applicable), but wrap the call inside
|
||||
-- a block to ensure that the object would still be deallocated in
|
||||
-- case the finalization fails. Generate:
|
||||
|
||||
-- begin
|
||||
-- [Deep_]Finalize (Obj_Ref.all);
|
||||
-- exception
|
||||
-- when others =>
|
||||
-- Free (Obj_Ref);
|
||||
-- raise;
|
||||
-- end;
|
||||
|
||||
if Needs_Finalization (DesigT) then
|
||||
Prepend_To (Stmts,
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => New_List (
|
||||
Make_Final_Call (
|
||||
Obj_Ref =>
|
||||
Make_Explicit_Dereference (Loc,
|
||||
Prefix => New_Copy (Obj_Ref)),
|
||||
Typ => DesigT)),
|
||||
|
||||
Exception_Handlers => New_List (
|
||||
Make_Exception_Handler (Loc,
|
||||
Exception_Choices => New_List (
|
||||
Make_Others_Choice (Loc)),
|
||||
Statements => New_List (
|
||||
New_Copy_Tree (Free_Stmt),
|
||||
Make_Raise_Statement (Loc)))))));
|
||||
end if;
|
||||
|
||||
-- Signal the accessibility failure through a Program_Error
|
||||
|
||||
Append_To (Stmts,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Condition => New_Reference_To (Standard_True, Loc),
|
||||
Reason => PE_Accessibility_Check_Failed));
|
||||
|
||||
-- Step 2: Create the accessibility comparison
|
||||
|
||||
-- Generate:
|
||||
-- Ref'Tag
|
||||
|
||||
Obj_Ref :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Node,
|
||||
Prefix => Obj_Ref,
|
||||
Attribute_Name => Name_Tag);
|
||||
|
||||
-- For tagged types, determine the accessibility level by looking
|
||||
-- at the type specific data of the dispatch table. Generate:
|
||||
|
||||
-- Type_Specific_Data (Address (Ref'Tag)).Access_Level
|
||||
|
||||
if Tagged_Type_Expansion then
|
||||
New_Node := Build_Get_Access_Level (Loc, New_Node);
|
||||
Cond := Build_Get_Access_Level (Loc, Obj_Ref);
|
||||
|
||||
elsif VM_Target /= No_VM then
|
||||
New_Node :=
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc),
|
||||
Parameter_Associations => New_List (New_Node));
|
||||
-- Use a runtime call to determine the accessibility level when
|
||||
-- compiling on virtual machine targets. Generate:
|
||||
|
||||
-- Cannot generate the runtime check
|
||||
-- Get_Access_Level (Ref'Tag)
|
||||
|
||||
else
|
||||
return;
|
||||
Cond :=
|
||||
Make_Function_Call (Loc,
|
||||
Name =>
|
||||
New_Reference_To (RTE (RE_Get_Access_Level), Loc),
|
||||
Parameter_Associations => New_List (Obj_Ref));
|
||||
end if;
|
||||
|
||||
Cond :=
|
||||
Make_Op_Gt (Loc,
|
||||
Left_Opnd => Cond,
|
||||
Right_Opnd =>
|
||||
Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
|
||||
|
||||
-- Due to the complexity and side effects of the check, utilize an
|
||||
-- if statement instead of the regular Program_Error circuitry.
|
||||
|
||||
Insert_Action (N,
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Condition =>
|
||||
Make_Op_Gt (Loc,
|
||||
Left_Opnd => New_Node,
|
||||
Right_Opnd =>
|
||||
Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
|
||||
Reason => PE_Accessibility_Check_Failed));
|
||||
Make_If_Statement (Loc,
|
||||
Condition => Cond,
|
||||
Then_Statements => Stmts));
|
||||
end if;
|
||||
end Apply_Accessibility_Check;
|
||||
|
||||
|
||||
@ -1562,7 +1562,12 @@ package body Ch6 is
|
||||
("(style) IN should be omitted");
|
||||
end if;
|
||||
|
||||
if Token = Tok_Access then
|
||||
-- Since Ada 2005, formal objects can have an anonymous access type,
|
||||
-- and of course carry a mode indicator.
|
||||
|
||||
if Token = Tok_Access
|
||||
and then Nkind (Node) /= N_Formal_Object_Declaration
|
||||
then
|
||||
Error_Msg_SP ("IN not allowed together with ACCESS");
|
||||
Scan; -- past ACCESS
|
||||
end if;
|
||||
|
||||
@ -342,8 +342,8 @@ locating the specified source files in the specified source directories.
|
||||
is explicitly specified.
|
||||
@xref{Naming Schemes}.
|
||||
|
||||
@item @code{Source Files}
|
||||
@cindex @code{Source_Files}
|
||||
@item @code{Source_Files}
|
||||
@cindex @code{Source_Files}
|
||||
In some cases, source directories might contain files that should not be
|
||||
included in a project. One can specify the explicit list of file names to
|
||||
be considered through the @b{Source_Files} attribute.
|
||||
|
||||
@ -253,7 +253,7 @@ package body Sem_Ch4 is
|
||||
function Try_Container_Indexing
|
||||
(N : Node_Id;
|
||||
Prefix : Node_Id;
|
||||
Expr : Node_Id) return Boolean;
|
||||
Exprs : List_Id) return Boolean;
|
||||
-- AI05-0139: Generalized indexing to support iterators over containers
|
||||
|
||||
function Try_Indexed_Call
|
||||
@ -2114,7 +2114,7 @@ package body Sem_Ch4 is
|
||||
then
|
||||
return;
|
||||
|
||||
elsif Try_Container_Indexing (N, P, Exp) then
|
||||
elsif Try_Container_Indexing (N, P, Exprs) then
|
||||
return;
|
||||
|
||||
elsif Array_Type = Any_Type then
|
||||
@ -2276,7 +2276,7 @@ package body Sem_Ch4 is
|
||||
end;
|
||||
end if;
|
||||
|
||||
elsif Try_Container_Indexing (N, P, First (Exprs)) then
|
||||
elsif Try_Container_Indexing (N, P, Exprs) then
|
||||
return;
|
||||
|
||||
end if;
|
||||
@ -6475,9 +6475,10 @@ package body Sem_Ch4 is
|
||||
function Try_Container_Indexing
|
||||
(N : Node_Id;
|
||||
Prefix : Node_Id;
|
||||
Expr : Node_Id) return Boolean
|
||||
Exprs : List_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Assoc : List_Id;
|
||||
Disc : Entity_Id;
|
||||
Func : Entity_Id;
|
||||
Func_Name : Node_Id;
|
||||
@ -6508,19 +6509,34 @@ package body Sem_Ch4 is
|
||||
if Has_Implicit_Dereference (Etype (Prefix)) then
|
||||
Build_Explicit_Dereference
|
||||
(Prefix, First_Discriminant (Etype (Prefix)));
|
||||
return Try_Container_Indexing (N, Prefix, Expr);
|
||||
return Try_Container_Indexing (N, Prefix, Exprs);
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Assoc := New_List (Relocate_Node (Prefix));
|
||||
|
||||
-- A generalized iterator may have nore than one index expression, so
|
||||
-- transfer all of them to the argument list to be used in the call.
|
||||
|
||||
declare
|
||||
Arg : Node_Id;
|
||||
|
||||
begin
|
||||
Arg := First (Exprs);
|
||||
while Present (Arg) loop
|
||||
Append (Relocate_Node (Arg), Assoc);
|
||||
Next (Arg);
|
||||
end loop;
|
||||
end;
|
||||
|
||||
if not Is_Overloaded (Func_Name) then
|
||||
Func := Entity (Func_Name);
|
||||
Indexing := Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Func, Loc),
|
||||
Parameter_Associations =>
|
||||
New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
|
||||
Parameter_Associations => Assoc);
|
||||
Rewrite (N, Indexing);
|
||||
Analyze (N);
|
||||
|
||||
@ -6544,8 +6560,7 @@ package body Sem_Ch4 is
|
||||
else
|
||||
Indexing := Make_Function_Call (Loc,
|
||||
Name => Make_Identifier (Loc, Chars (Func_Name)),
|
||||
Parameter_Associations =>
|
||||
New_List (Relocate_Node (Prefix), Relocate_Node (Expr)));
|
||||
Parameter_Associations => Assoc);
|
||||
|
||||
Rewrite (N, Indexing);
|
||||
|
||||
@ -6586,7 +6601,8 @@ package body Sem_Ch4 is
|
||||
end if;
|
||||
|
||||
if Etype (N) = Any_Type then
|
||||
Error_Msg_NE ("container cannot be indexed with&", N, Etype (Expr));
|
||||
Error_Msg_NE ("container cannot be indexed with&",
|
||||
N, Etype (First (Exprs)));
|
||||
Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
|
||||
else
|
||||
Analyze (N);
|
||||
|
||||
@ -7057,11 +7057,16 @@ package body Sem_Res is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
New_N : Node_Id;
|
||||
P : constant Node_Id := Prefix (N);
|
||||
|
||||
P_Typ : Entity_Id;
|
||||
-- The candidate prefix type, if overloaded
|
||||
|
||||
I : Interp_Index;
|
||||
It : Interp;
|
||||
|
||||
begin
|
||||
Check_Fully_Declared_Prefix (Typ, P);
|
||||
P_Typ := Empty;
|
||||
|
||||
if Is_Overloaded (P) then
|
||||
|
||||
@ -7069,14 +7074,28 @@ package body Sem_Res is
|
||||
-- designated type.
|
||||
|
||||
Get_First_Interp (P, I, It);
|
||||
|
||||
while Present (It.Typ) loop
|
||||
exit when Is_Access_Type (It.Typ)
|
||||
and then Covers (Typ, Designated_Type (It.Typ));
|
||||
if Is_Access_Type (It.Typ)
|
||||
and then Covers (Typ, Designated_Type (It.Typ))
|
||||
then
|
||||
P_Typ := It.Typ;
|
||||
|
||||
-- Remove access types that do not match, but preserve access
|
||||
-- to subprogram interpretations, in case a further dereference
|
||||
-- is needed (see below).
|
||||
|
||||
elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then
|
||||
Remove_Interp (I);
|
||||
end if;
|
||||
|
||||
Get_Next_Interp (I, It);
|
||||
end loop;
|
||||
|
||||
if Present (It.Typ) then
|
||||
Resolve (P, It.Typ);
|
||||
if Present (P_Typ) then
|
||||
Resolve (P, P_Typ);
|
||||
Set_Etype (N, Designated_Type (P_Typ));
|
||||
|
||||
else
|
||||
-- If no interpretation covers the designated type of the prefix,
|
||||
-- this is the pathological case where not all implementations of
|
||||
@ -7107,9 +7126,9 @@ package body Sem_Res is
|
||||
return;
|
||||
end if;
|
||||
|
||||
Set_Etype (N, Designated_Type (It.Typ));
|
||||
|
||||
else
|
||||
-- If not overloaded, resolve P with its own type
|
||||
|
||||
Resolve (P);
|
||||
end if;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user