diff mbox

[Ada] Illegal use of type name in a context where it is not a current instance.

Message ID 20160419121906.GA66914@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet April 19, 2016, 12:19 p.m. UTC
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  <schonberg@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.
diff mbox

Patch

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;