+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Is_Predicate_Static): An inherited predicate
+ can be static only if it applies to a scalar type.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Adjust_Result_Type): Convert operand to base
+ type to prevent spurious constraint checks on subtypes of Boolean.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * debug.adb: Document debug switch -gnatd.o.
+ * sem_elab.adb (Check_Internal_Call): Debug switch -gnatd.o
+ now causes a more conservative treatment of indirect calls,
+ treating P'Access as a call to P in more cases. We Can't make
+ this the default, because it breaks common idioms, for example
+ the soft links.
+ * sem_util.adb: Add an Assert.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.ads, a-cuprqu.adb: Completely rewrite this package. Use
+ red-black trees, which gives O(lg N) worst-case performance on
+ Enqueue and Dequeue. The previous version had O(N) Enqueue in
+ the worst case.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_warn.adb: minor style fix in comment.
+ * spark_xrefs.ads (Scope_Num): type refined to positive integers.
+ * lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope):
+ moved into scope of Collect_SPARK_Xrefs.
+ (Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs;
+ now uses Dspec and Scope_Id from Collect_SPARK_Xrefs.
+ (Collect_SPARK_Xrefs): refactored to avoid retraversing the list
+ of scopes.
+ * sem_ch3.adb (Build_Discriminal): Set Parent of the discriminal.
+
2016-06-22 Arnaud Charlet <charlet@adacore.com>
* lib-xref-spark_specific.adb (Generate_Dereference): Assignment to not
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, 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- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
-
package body Ada.Containers.Unbounded_Priority_Queues is
- package body Implementation is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Before_Or_Equal (X, Y : Queue_Priority) return Boolean;
- -- True if X is before or equal to Y. Equal means both Before(X,Y) and
- -- Before(Y,X) are False.
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- ---------------------
- -- Before_Or_Equal --
- ---------------------
-
- function Before_Or_Equal (X, Y : Queue_Priority) return Boolean is
- begin
- return (if Before (X, Y) then True else not Before (Y, X));
- end Before_Or_Equal;
-
- -------------
- -- Dequeue --
- -------------
-
- procedure Dequeue
- (List : in out List_Type;
- Element : out Queue_Interfaces.Element_Type)
- is
- H : constant Node_Access := List.Header'Unchecked_Access;
- pragma Assert (List.Length /= 0);
- pragma Assert (List.Header.Next /= H);
- -- List can't be empty; see the barrier
-
- pragma Assert
- (List.Header.Next.Next = H or else
- Before_Or_Equal (Get_Priority (List.Header.Next.Element),
- Get_Priority (List.Header.Next.Next.Element)));
- -- The first item is before-or-equal to the second
-
- pragma Assert
- (List.Header.Next.Next_Unequal = H or else
- Before (Get_Priority (List.Header.Next.Element),
- Get_Priority (List.Header.Next.Next_Unequal.Element)));
- -- The first item is before its Next_Unequal item
-
- -- The highest-priority item is always first; just remove it and
- -- return that element.
-
- X : Node_Access := List.Header.Next;
-
- -- Start of processing for Dequeue
-
- begin
- Element := X.Element;
- X.Next.Prev := H;
- List.Header.Next := X.Next;
- List.Header.Next_Unequal := X.Next;
- List.Length := List.Length - 1;
- Free (X);
- 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
- -- This operation dequeues a high priority item if it exists in the
- -- queue. By "high priority" we mean an item whose priority is equal
- -- or greater than the value At_Least. The generic formal operation
- -- Before has the meaning "has higher priority than". To dequeue an
- -- item (meaning that we return True as our Success value), we need
- -- as our predicate the equivalent of "has equal or higher priority
- -- than", but we cannot say that directly, so we require some logical
- -- gymnastics to make it so.
-
- -- If E is the element at the head of the queue, and symbol ">"
- -- refers to the "is higher priority than" function Before, then we
- -- derive our predicate as follows:
- -- original: P(E) >= At_Least
- -- same as: not (P(E) < At_Least)
- -- same as: not (At_Least > P(E))
- -- same as: not Before (At_Least, P(E))
-
- -- But that predicate needs to be true in order to successfully
- -- dequeue an item. If it's false, it means no item is dequeued, and
- -- we return False as the Success value.
-
- Success := List.Length > 0
- and then
- not Before (At_Least, Get_Priority (List.Header.Next.Element));
-
- if Success then
- List.Dequeue (Element);
- end if;
- 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);
- H : constant Node_Access := List.Header'Unchecked_Access;
-
- function Next return Node_Access;
- -- The node before which we wish to insert the new node
-
- ----------
- -- Next --
- ----------
-
- function Next return Node_Access is
- begin
- return Result : Node_Access := H.Next_Unequal do
- while Result /= H
- and then not Before (P, Get_Priority (Result.Element))
- loop
- Result := Result.Next_Unequal;
- end loop;
- end return;
- end Next;
-
- -- Local varaibles
-
- Prev : constant Node_Access := Next.Prev;
- -- The node after which we wish to insert the new node. So Prev must
- -- be the header, or be higher or equal priority to the new item.
- -- Prev.Next must be the header, or be lower priority than the
- -- new item.
-
- pragma Assert
- (Prev = H or else Before_Or_Equal (Get_Priority (Prev.Element), P));
- pragma Assert
- (Prev.Next = H
- or else Before (P, Get_Priority (Prev.Next.Element)));
- pragma Assert (Prev.Next = Prev.Next_Unequal);
-
- Node : constant Node_Access :=
- new Node_Type'(New_Item,
- Prev => Prev,
- Next => Prev.Next,
- Next_Unequal => Prev.Next);
-
- -- Start of processing for Enqueue
-
- begin
- Prev.Next.Prev := Node;
- Prev.Next := Node;
-
- if Prev = H then
-
- -- Make sure Next_Unequal of the Header always points to the first
- -- "real" node. Here, we've inserted a new first "real" node, so
- -- must update.
-
- List.Header.Next_Unequal := Node;
-
- elsif Before (Get_Priority (Prev.Element), P) then
-
- -- If the new item inserted has a unique priority in queue (not
- -- same priority as precedent), set Next_Unequal of precedent
- -- element to the new element instead of old next element, since
- -- Before (P, Get_Priority (Next.Element) or Next = H).
-
- Prev.Next_Unequal := Node;
- end if;
-
- pragma Assert (List.Header.Next_Unequal = List.Header.Next);
-
- List.Length := List.Length + 1;
-
- if List.Length > List.Max_Length then
- List.Max_Length := List.Length;
- end if;
- end Enqueue;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (List : in out List_Type) is
- Ignore : Queue_Interfaces.Element_Type;
- begin
- while List.Length > 0 loop
- List.Dequeue (Ignore);
- 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
-----------------
function Current_Use return Count_Type is
begin
- return List.Length;
+ return Q_Elems.Length;
end Current_Use;
-------------
-------------
entry Dequeue (Element : out Queue_Interfaces.Element_Type)
- when List.Length > 0
+ when Q_Elems.Length > 0
is
+ -- Grab the first item of the set, and remove it from the set
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (Element);
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
end Dequeue;
--------------------------------
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean)
is
+ -- Grab the first item. If it exists and has appropriate priority,
+ -- set Success to True, and remove that item. Otherwise, set Success
+ -- to False.
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (At_Least, Element, Success);
+ Success := Has_Element (C) and then
+ not Before (At_Least, Get_Priority (Sets.Element (C).Item));
+
+ if Success then
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
+ end if;
end Dequeue_Only_High_Priority;
-------------
entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is
begin
- List.Enqueue (New_Item);
+ Insert (Q_Elems, (Next_Sequence_Number, New_Item));
+ Next_Sequence_Number := Next_Sequence_Number + 1;
+
+ -- If we reached a new high-water mark, increase Max_Length
+
+ if Q_Elems.Length > Max_Length then
+ pragma Assert (Max_Length + 1 = Q_Elems.Length);
+ Max_Length := Q_Elems.Length;
+ end if;
end Enqueue;
--------------
function Peak_Use return Count_Type is
begin
- return List.Max_Length;
+ return Max_Length;
end Peak_Use;
end Queue;
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
------------------------------------------------------------------------------
with System;
+with Ada.Containers.Ordered_Sets;
with Ada.Containers.Synchronized_Queue_Interfaces;
-with Ada.Finalization;
generic
with package Queue_Interfaces is
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;
+ -- We use an ordered set to hold the queue elements. This gives O(lg N)
+ -- performance in the worst case for Enqueue and Dequeue.
+ -- Sequence_Number is used to distinguish equivalent items. Each Enqueue
+ -- uses a higher Sequence_Number, so that a new item is placed after
+ -- already-enqueued equivalent items.
+ --
+ -- At any time, the first set element is the one to be dequeued next (if
+ -- the queue is not empty).
- function Max_Length (List : List_Type) return Count_Type;
+ type Set_Elem is record
+ Sequence_Number : Count_Type;
+ Item : Queue_Interfaces.Element_Type;
+ end record;
- private
+ function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is
+ (not Before (Get_Priority (X), Get_Priority (Y))
+ and then not Before (Get_Priority (Y), Get_Priority (X)));
+ -- Elements are equal if neither is Before the other
- -- List_Type is implemented as a circular doubly-linked list with a
- -- dummy header node; Prev and Next are the links. The list is in
- -- decreasing priority order, so the highest-priority item is always
- -- first. (If there are multiple items with the highest priority, the
- -- oldest one is first.) Header.Element is undefined and not used.
- --
- -- In addition, Next_Unequal points to the next item with a different
- -- (i.e. strictly lower) priority. This is used to speed up the search
- -- for the next lower-priority item, in cases where there are many items
- -- with the same priority.
- --
- -- An empty list has Header.Prev, Header.Next, and Header.Next_Unequal
- -- all pointing to Header. A nonempty list has Header.Next_Unequal
- -- pointing to the first "real" item, and the last item has Next_Unequal
- -- pointing back to Header.
-
- type Node_Type;
- type Node_Access is access all Node_Type;
-
- type Node_Type is limited record
- Element : Queue_Interfaces.Element_Type;
- Prev, Next : Node_Access := Node_Type'Unchecked_Access;
- Next_Unequal : Node_Access := Node_Type'Unchecked_Access;
- end record;
+ function "=" (X, Y : Set_Elem) return Boolean is
+ (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item);
+ -- Set_Elems are equal if the elements are equal, and the
+ -- Sequence_Numbers are equal. This is passed to Ordered_Sets.
- type List_Type is new Ada.Finalization.Limited_Controlled with record
- Header : aliased Node_Type;
- Length : Count_Type := 0;
- Max_Length : Count_Type := 0;
- end record;
+ function "<" (X, Y : Set_Elem) return Boolean is
+ (if X.Item = Y.Item
+ then X.Sequence_Number < Y.Sequence_Number
+ else Before (Get_Priority (X.Item), Get_Priority (Y.Item)));
+ -- If the items are equal, Sequence_Number breaks the tie. Otherwise,
+ -- use Before. This is passed to Ordered_Sets.
- overriding procedure Finalize (List : in out List_Type);
+ pragma Suppress (Container_Checks);
+ package Sets is new Ada.Containers.Ordered_Sets (Set_Elem);
end Implementation;
+ use Implementation, Implementation.Sets;
+
protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling)
with
Priority => Ceiling
overriding function Peak_Use return Count_Type;
private
- List : Implementation.List_Type;
+ Q_Elems : Set;
+ -- Elements of the queue
+
+ Max_Length : Count_Type := 0;
+ -- The current length of the queue is the Length of Q_Elems. This is the
+ -- maximum value of that, so far. Updated by Enqueue.
+
+ Next_Sequence_Number : Count_Type := 0;
+ -- Steadily increasing counter
end Queue;
end Ada.Containers.Unbounded_Priority_Queues;
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
- -- d.o
+ -- d.o Conservative elaboration order for indirect calls
-- d.p
-- d.q
-- d.r Enable OK_To_Reorder_Components in non-variant records
-- compiler has a bug -- these are the files that need to be included
-- in a bug report.
+ -- d.o Conservative elaboration order for indirect calls. This causes
+ -- P'Access to be treated as a call in more cases.
+
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
return;
-- Otherwise we perform a conversion from the current type, which
- -- must be Standard.Boolean, to the desired type.
+ -- must be Standard.Boolean, to the desired type. Use the base
+ -- type to prevent spurious constraint checks that are extraneous
+ -- to the transformation. The type and its base have the same
+ -- representation, standard or otherwise.
else
Set_Analyzed (N);
- Rewrite (N, Convert_To (T, N));
- Analyze_And_Resolve (N, T);
+ Rewrite (N, Convert_To (Base_Type (T), N));
+ Analyze_And_Resolve (N, Base_Type (T));
end if;
end;
end if;
Expression => Expr))));
-- If declaration has not been analyzed yet, Insert declaration
- -- before freeze node.
- -- Insert body after freeze node.
+ -- before freeze node. Insert body itself after freeze node.
if not Analyzed (FDecl) then
Insert_Before_And_Analyze (N, FDecl);
-- to specify a static predicate for a subtype which is inheriting a
-- dynamic predicate, so the static predicate validation here ignores
-- the inherited predicate even if it is dynamic.
+ -- In all cases, a static predicate can only apply to a scalar type.
elsif Nkind (Expr) = N_Function_Call
and then Is_Predicate_Function (Entity (Name (Expr)))
+ and then Is_Scalar_Type (Etype (First_Entity (Entity (Name (Expr)))))
then
return True;
Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim));
Set_Scope (D_Minal, Current_Scope);
+ Set_Parent (D_Minal, Parent (Discrim));
Set_Discriminal (Discrim, D_Minal);
Set_Discriminal_Link (D_Minal, Discrim);
-- node comes from source.
if Nkind (N) = N_Attribute_Reference
- and then (not Warn_On_Elab_Access or else not Comes_From_Source (N))
+ and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
+ or else not Comes_From_Source (N))
then
return;
Encl_Unit := Library_Unit (Encl_Unit);
end loop;
+ pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
return Encl_Unit;
end Enclosing_Lib_Unit_Node;
P := Parent (C);
loop
-- If tree is not attached, do not issue warning (this is very
- -- peculiar, and probably arises from some other error condition)
+ -- peculiar, and probably arises from some other error condition).
if No (P) then
return;
projects / gcc.git / commitdiff