OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r237687
This commit is contained in:
Arnaud Charlet 2016-06-22 12:00:24 +02:00
parent 3ae6c64384
commit f24ea9120d
10 changed files with 128 additions and 284 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
gcc/ada/ChangeLog
View File

@ -1,3 +1,42 @@
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

254
gcc/ada/a-cuprqu.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -27,225 +27,8 @@
-- 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
-----------------
@ -254,7 +37,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is
function Current_Use return Count_Type is
begin
return List.Length;
return Q_Elems.Length;
end Current_Use;
-------------
@ -262,10 +45,14 @@ package body Ada.Containers.Unbounded_Priority_Queues is
-------------
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;
--------------------------------
@ -277,8 +64,19 @@ package body Ada.Containers.Unbounded_Priority_Queues is
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;
-------------
@ -287,7 +85,15 @@ package body Ada.Containers.Unbounded_Priority_Queues is
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;
--------------
@ -296,7 +102,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is
function Peak_Use return Count_Type is
begin
return List.Max_Length;
return Max_Length;
end Peak_Use;
end Queue;

93
gcc/ada/a-cuprqu.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
@ -32,8 +32,8 @@
------------------------------------------------------------------------------
with System;
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Synchronized_Queue_Interfaces;
with Ada.Finalization;
generic
with package Queue_Interfaces is
@ -59,63 +59,44 @@ package Ada.Containers.Unbounded_Priority_Queues 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;
function Max_Length (List : List_Type) return Count_Type;
private
-- 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.
-- 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.
--
-- 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.
-- At any time, the first set element is the one to be dequeued next (if
-- the queue is not empty).
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;
type Set_Elem is record
Sequence_Number : Count_Type;
Item : Queue_Interfaces.Element_Type;
end record;
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 : 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
overriding procedure Finalize (List : in out List_Type);
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.
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.
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
@ -142,7 +123,15 @@ package Ada.Containers.Unbounded_Priority_Queues is
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;

5
gcc/ada/debug.adb
View File

@ -105,7 +105,7 @@ package body Debug is
-- 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
@ -556,6 +556,9 @@ package body Debug is
-- 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.

9
gcc/ada/exp_util.adb
View File

@ -355,12 +355,15 @@ package body Exp_Util is
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;

5
gcc/ada/sem_ch13.adb
View File

@ -8552,8 +8552,7 @@ package body Sem_Ch13 is
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);
@ -11644,9 +11643,11 @@ package body Sem_Ch13 is
-- 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;

1
gcc/ada/sem_ch3.adb
View File

@ -9182,6 +9182,7 @@ package body Sem_Ch3 is
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);

3
gcc/ada/sem_elab.adb
View File

@ -2139,7 +2139,8 @@ package body Sem_Elab is
-- 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;

1
gcc/ada/sem_util.adb
View File

@ -6314,6 +6314,7 @@ package body Sem_Util is
Encl_Unit := Library_Unit (Encl_Unit);
end loop;
pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
return Encl_Unit;
end Enclosing_Lib_Unit_Node;

2
gcc/ada/sem_warn.adb
View File

@ -3367,7 +3367,7 @@ package body Sem_Warn is
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;