This patch fixes an omission in the code that checks the legality of a type
name as a prefix of 'access. These uses are allowed when the type name is a
current instance, but previously the compiler allowed these uses within
aggregates not within the declarative region of the type.
Compiling priority_queues.adb must yield:
priority_queues.adb:85:48:
"Unchecked_Access" attribute cannot be applied to type
priority_queues.adb:86:48:
"Unchecked_Access" attribute cannot be applied to type
---
with System;
with Ada.Containers.Synchronized_Queue_Interfaces;
with Ada.Finalization;
with Ada.Containers;
use Ada.Containers;
generic
with package Queue_Interfaces is
new Ada.Containers.Synchronized_Queue_Interfaces (<>);
type Queue_Priority is private;
with function Get_Priority
(Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>;
with function Before
(Left, Right : Queue_Priority) return Boolean is <>;
Default_Ceiling : System.Any_Priority := System.Priority'Last;
package Priority_Queues is
pragma Preelaborate;
package Implementation is
-- All identifiers in this unit are implementation defined
pragma Implementation_Defined;
type List_Type is tagged limited private;
procedure Enqueue
(List : in out List_Type;
New_Item : Queue_Interfaces.Element_Type);
procedure Dequeue
(List : in out List_Type;
Element : out Queue_Interfaces.Element_Type);
procedure Dequeue
(List : in out List_Type;
At_Least : Queue_Priority;
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean);
function Length (List : List_Type) return Count_Type;
function Max_Length (List : List_Type) return Count_Type;
private
type Node_Type;
type Node_Access is access all Node_Type;
type Node_Type is limited record
Element : Queue_Interfaces.Element_Type;
Next : Node_Access;
First_Equal, Last_Equal : Node_Access;
end record;
type List_Type is new Ada.Finalization.Limited_Controlled with record
First, Last : Node_Access;
Length : Count_Type := 0;
Max_Length : Count_Type := 0;
end record;
overriding procedure Finalize (List : in out List_Type);
end Implementation;
protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling)
with
Priority => Ceiling
is new Queue_Interfaces.Queue with
overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type);
overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type);
-- The priority queue operation Dequeue_Only_High_Priority had been a
-- protected entry in early drafts of AI05-0159, but it was discovered
-- that that operation as specified was not in fact implementable. The
-- operation was changed from an entry to a protected procedure per the
-- ARG meeting in Edinburgh (June 2011), with a different signature and
-- semantics.
procedure Dequeue_Only_High_Priority
(At_Least : Queue_Priority;
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean);
overriding function Current_Use return Count_Type;
overriding function Peak_Use return Count_Type;
private
List : Implementation.List_Type;
end Queue;
end Priority_Queues;
---
with Ada.Unchecked_Deallocation;
package body Priority_Queues is
package body Implementation is
-----------------------
-- Local Subprograms --
-----------------------
procedure Free is
new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-------------
-- Dequeue --
-------------
procedure Dequeue
(List : in out List_Type;
Element : out Queue_Interfaces.Element_Type)
is
X : Node_Access;
begin
Element := List.First.Element;
X := List.First;
if X.Last_Equal = X then
-- Nothing to do
null;
else
-- new First_Equal is next node
X.Last_Equal.First_Equal := X.Next;
-- update First_Equal / Last_Equal of next node with current last
X.Next.Last_Equal := X.Last_Equal;
X.Next.First_Equal := X.Next;
end if;
List.First := List.First.Next;
if List.First = null then
List.Last := null;
end if;
List.Length := List.Length - 1;
pragma Warnings (Off, """X"" modified by call, but never referenced");
Free (X);
pragma Warnings (On, """X"" modified by call, but never referenced");
end Dequeue;
procedure Dequeue
(List : in out List_Type;
At_Least : Queue_Priority;
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean)
is
begin
if List.Length = 0
or else Before (At_Least, Get_Priority (List.First.Element))
then
Success := False;
return;
end if;
List.Dequeue (Element);
Success := True;
end Dequeue;
-------------
-- Enqueue --
-------------
procedure Enqueue
(List : in out List_Type;
New_Item : Queue_Interfaces.Element_Type)
is
P : constant Queue_Priority := Get_Priority (New_Item);
Node : Node_Access;
Prev : Node_Access;
begin
Node := new Node_Type'(Element => New_Item,
Next => null,
First_Equal => Node_Type'Unchecked_Access,
Last_Equal => Node_Type'Unchecked_Access);
if List.First = null then
List.First := Node;
List.Last := List.First;
else
Prev := List.First;
if Before (P, Get_Priority (Prev.Element)) then
Node.Next := List.First;
List.First := Node;
else
Prev := Prev.Last_Equal;
while Prev.Next /= null
and then Before (P, Get_Priority (Prev.Next.Element)) = False
loop
-- Set Prev as last element of same priority than
-- next element (next priority)
Prev := Prev.Next.Last_Equal;
end loop;
if Prev.Next = null then
-- Last element of queue reached: new element is last
List.Last.Next := Node;
List.Last := Node;
else
-- Element after which new element must be inserted found
Node.Next := Prev.Next;
Prev.Next := Node;
if Before (Get_Priority (Prev.Element), P) then
-- Precedent element has not same priority
null;
else
Node.First_Equal := Prev.First_Equal;
-- update only Last_Equal of First_Equal node:
Node.First_Equal.Last_Equal := Node;
end if;
end if;
end if;
end if;
List.Length := List.Length + 1;
if List.Length > List.Max_Length then
List.Max_Length := List.Length;
end if;
end Enqueue;
--------------
-- Finalize --
--------------
overriding
procedure Finalize (List : in out List_Type) is
X : Node_Access;
begin
while List.First /= null loop
X := List.First;
List.First := List.First.Next;
Free (X);
end loop;
end Finalize;
------------
-- Length --
------------
function Length (List : List_Type) return Count_Type is
begin
return List.Length;
end Length;
----------------
-- Max_Length --
----------------
function Max_Length (List : List_Type) return Count_Type is
begin
return List.Max_Length;
end Max_Length;
end Implementation;
protected body Queue is
-----------------
-- Current_Use --
-----------------
function Current_Use return Count_Type is
begin
return List.Length;
end Current_Use;
-------------
-- Dequeue --
-------------
entry Dequeue (Element : out Queue_Interfaces.Element_Type)
when List.Length > 0
is
begin
List.Dequeue (Element);
end Dequeue;
--------------------------------
-- Dequeue_Only_High_Priority --
--------------------------------
procedure Dequeue_Only_High_Priority
(At_Least : Queue_Priority;
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean)
is
begin
List.Dequeue (At_Least, Element, Success);
end Dequeue_Only_High_Priority;
-------------
-- Enqueue --
-------------
entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is
begin
List.Enqueue (New_Item);
end Enqueue;
--------------
-- Peak_Use --
--------------
function Peak_Use return Count_Type is
begin
return List.Max_Length;
end Peak_Use;
end Queue;
end Priority_Queues;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-04-19 Ed Schonberg <schonb...@adacore.com>
* sem_attr.adb (Analyze_Access_Attribute, OK_Self_Reference):
Reject use of type name as a prefix to 'access within an aggregate
in a context that is not the declarative region of a type.
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 235135)
+++ sem_attr.adb (working copy)
@@ -748,7 +748,25 @@
if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
if Etype (Par) = Typ then
Set_Has_Self_Reference (Par);
- return True;
+
+ -- Check the context: the aggregate must be part of the
+ -- initialization of a type or component, or it is the
+ -- resulting expansion in an initialization procedure.
+
+ if Is_Init_Proc (Current_Scope) then
+ return True;
+ else
+ Par := Parent (Par);
+ while Present (Par) loop
+ if Nkind (Par) = N_Full_Type_Declaration then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+ end if;
+
+ return False;
end if;
end if;
