Skip to content

R
riscv-gcc-1
Commit fd8b8c01 by Arnaud Charlet
Options

[multiple changes] 

2013-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* checks.adb (Apply_Predicate_Check): Update the comment associated
	with the call to Check_Expression_Against_Static_Predicate.
	* sem_ch3.adb (Analyze_Object_Declaration): Update the comment
	associated with the call to Check_Expression_Against_Static_Predicate.
	* sem_util.adb (Check_Expression_Against_Static_Predicate):
	Broaden the check from a static expression to an expression with
	a known value at compile time.
	* sem_util.ads (Check_Expression_Against_Static_Predicate): Update
	comment on usage.

2013-04-25  Thomas Quinot  <quinot@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, cases Position,
	First_Bit, and Last_Bit): Fix incorrect test in implementation of
	RM 2005 13.5.2(3/2).

2013-04-25  Claire Dross  <dross@adacore.com>

	* a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads, a-cfhama.adb,
	a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads
	(Query_Element): Removed.
	(Update_Element): Removed.
	(Insert): The version with no New_Item specified is removed.
	(Iterate): Removed.
	(Write): Removed.
	(Read): Removed.
	Every check of fields Busy and Lock has been removed.

2013-04-25  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Analyze_Pragma, case Contract_Cases): Remove
	call to S14_Pragma (Find_Related_Subprogram): Require proper
	placement in subprogram body (Find_Related_Subprogram): Detect
	duplicates for all cases (Find_Related_Subprogram): Handle case
	of spec nested inside body.

From-SVN: r198297
parent f197d2f2
Showing with 168 additions and 2008 deletions
gcc/ada/ChangeLog
2013-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* checks.adb (Apply_Predicate_Check): Update the comment associated
with the call to Check_Expression_Against_Static_Predicate.
* sem_ch3.adb (Analyze_Object_Declaration): Update the comment
associated with the call to Check_Expression_Against_Static_Predicate.
* sem_util.adb (Check_Expression_Against_Static_Predicate):
Broaden the check from a static expression to an expression with
a known value at compile time.
* sem_util.ads (Check_Expression_Against_Static_Predicate): Update
comment on usage.
2013-04-25 Thomas Quinot <quinot@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, cases Position,
First_Bit, and Last_Bit): Fix incorrect test in implementation of
RM 2005 13.5.2(3/2).
2013-04-25 Claire Dross <dross@adacore.com>
* a-cfhase.adb, a-cfhase.ads, a-cforma.adb, a-cforma.ads, a-cfhama.adb,
a-cfhama.ads, a-cforse.adb, a-cforse.ads, a-cofove.adb, a-cofove.ads
(Query_Element): Removed.
(Update_Element): Removed.
(Insert): The version with no New_Item specified is removed.
(Iterate): Removed.
(Write): Removed.
(Read): Removed.
Every check of fields Busy and Lock has been removed.
2013-04-25 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Analyze_Pragma, case Contract_Cases): Remove
call to S14_Pragma (Find_Related_Subprogram): Require proper
placement in subprogram body (Find_Related_Subprogram): Detect
duplicates for all cases (Find_Related_Subprogram): Handle case
of spec nested inside body.
2013-04-25 Arnaud Charlet <charlet@adacore.com>
* par-prag.adb: Fix typo.
......
gcc/ada/a-cfhama.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, 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- --
......@@ -159,8 +159,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Source length exceeds Target capacity";
end if;
-- Check busy bits
Clear (Target);
Insert_Elements (Source);
......@@ -266,11 +264,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Position cursor of Delete has no element";
end if;
if Container.Busy > 0 then
raise Program_Error with
"Delete attempted to tamper with elements (map is busy)";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
......@@ -495,10 +488,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
if Container.Lock > 0 then
raise Program_Error with
"Include attempted to tamper with cursors (map is locked)";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
......@@ -516,54 +505,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
procedure Insert
(Container : in out Map;
Key : Key_Type;
Position : out Cursor;
Inserted : out Boolean)
is
procedure Assign_Key (Node : in out Node_Type);
pragma Inline (Assign_Key);
function New_Node return Count_Type;
pragma Inline (New_Node);
procedure Local_Insert is
new Key_Ops.Generic_Conditional_Insert (New_Node);
procedure Allocate is
new Generic_Allocate (Assign_Key);
-----------------
-- Assign_Key --
-----------------
procedure Assign_Key (Node : in out Node_Type) is
begin
Node.Key := Key;
-- What is following commented out line doing here ???
-- Node.Element := New_Item;
end Assign_Key;
--------------
-- New_Node --
--------------
function New_Node return Count_Type is
Result : Count_Type;
begin
Allocate (Container, Result);
return Result;
end New_Node;
-- Start of processing for Insert
begin
Local_Insert (Container, Key, Position.Node, Inserted);
end Insert;
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean)
......@@ -635,47 +576,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
return Length (Container) = 0;
end Is_Empty;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Map;
Process : not null
access procedure (Container : Map; Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Count_Type) is
begin
Process (Container, (Node => Node));
end Process_Node;
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
begin
Local_Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
---------
-- Key --
---------
......@@ -752,11 +652,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Source length exceeds Target capacity";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
if Source.Length = 0 then
......@@ -849,105 +744,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
return False;
end Overlap;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
N : Node_Type renames Container.Nodes (Position.Node);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Map)
is
function Read_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type;
procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node);
---------------
-- Read_Node --
---------------
function Read_Node
(Stream : not null access Root_Stream_Type'Class) return Count_Type
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is
new Generic_Allocate (Read_Element);
procedure Read_Element (Node : in out Node_Type) is
begin
Element_Type'Read (Stream, Node.Element);
end Read_Element;
Node : Count_Type;
-- Start of processing for Read_Node
begin
Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
begin
Read_Nodes (Stream, Container);
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
-- Replace --
-------------
......@@ -965,11 +761,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
"attempt to replace key not in map";
end if;
if Container.Lock > 0 then
raise Program_Error with
"Replace attempted to tamper with cursors (map is locked)";
end if;
declare
N : Node_Type renames Container.Nodes (Node);
begin
......@@ -993,11 +784,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
"Position cursor of Replace_Element has no element";
end if;
if Container.Lock > 0 then
raise Program_Error with
"Replace_Element attempted to tamper with cursors (map is locked)";
end if;
pragma Assert (Vet (Container, Position),
"bad cursor in Replace_Element");
......@@ -1085,52 +871,6 @@ package body Ada.Containers.Formal_Hashed_Maps is
return True;
end Strict_Equal;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
end if;
pragma Assert (Vet (Container, Position),
"bad cursor in Update_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
---------
-- Vet --
---------
......@@ -1191,46 +931,4 @@ package body Ada.Containers.Formal_Hashed_Maps is
end;
end Vet;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Map)
is
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type);
pragma Inline (Write_Node);
procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
----------------
-- Write_Node --
----------------
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type)
is
begin
Key_Type'Write (Stream, Node.Key);
Element_Type'Write (Stream, Node.Element);
end Write_Node;
-- Start of processing for Write
begin
Write_Nodes (Stream, Container);
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error with "attempt to stream map cursor";
end Write;
end Ada.Containers.Formal_Hashed_Maps;
gcc/ada/a-cfhama.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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 --
......@@ -52,7 +52,6 @@
-- See detailed specifications for these subprograms
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
generic
type Key_Type is private;
......@@ -87,14 +86,15 @@ package Ada.Containers.Formal_Hashed_Maps is
function Is_Empty (Container : Map) return Boolean;
-- ??? what does clear do to active elements?
procedure Clear (Container : in out Map);
procedure Assign (Target : in out Map; Source : Map);
-- ???
-- capacity=0 means use container.length as cap of tgt
-- modulos=0 means use default_modulous(container.length)
-- Copy returns a container stricty equal to Source
-- It must have the same cursors associated to each element
-- Therefore:
-- - capacity=0 means use container.capacity as cap of tgt
-- - the modulus cannot be changed.
function Copy
(Source : Map;
Capacity : Count_Type := 0) return Map;
......@@ -108,18 +108,6 @@ package Ada.Containers.Formal_Hashed_Maps is
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type));
procedure Update_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : in out Element_Type));
procedure Move (Target : in out Map; Source : in out Map);
procedure Insert
......@@ -132,12 +120,6 @@ package Ada.Containers.Formal_Hashed_Maps is
procedure Insert
(Container : in out Map;
Key : Key_Type;
Position : out Cursor;
Inserted : out Boolean);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Include
......@@ -186,11 +168,6 @@ package Ada.Containers.Formal_Hashed_Maps is
Right : Map;
CRight : Cursor) return Boolean;
procedure Iterate
(Container : Map;
Process : not null access
procedure (Container : Map; Position : Cursor));
function Default_Modulus (Capacity : Count_Type) return Hash_Type;
function Strict_Equal (Left, Right : Map) return Boolean;
......@@ -237,39 +214,11 @@ private
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Map);
for Map'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Map);
for Map'Read use Read;
type Map_Access is access all Map;
for Map_Access'Storage_Size use 0;
type Cursor is record
Node : Count_Type;
end record;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>);
No_Element : constant Cursor := (Node => 0);
......
gcc/ada/a-cfhase.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, 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- --
......@@ -295,11 +295,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
raise Constraint_Error with "Position cursor has no element";
end if;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Delete");
HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
......@@ -333,11 +328,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
if Src_Length >= Target.Length then
Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
......@@ -572,9 +562,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
end;
end Equivalent_Elements;
-- What does the following comment signify???
-- NOT MODIFIED
---------------------
-- Equivalent_Keys --
---------------------
......@@ -700,10 +687,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Container.Nodes (Position.Node).Element := New_Item;
end if;
......@@ -804,11 +787,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
Tgt_Node := HT_Ops.First (Target);
while Tgt_Node /= 0 loop
if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
......@@ -930,48 +908,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return True;
end Is_Subset;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Count_Type) is
begin
Process (Container, (Node => Node));
end Process_Node;
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
begin
Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
----------
-- Left --
----------
......@@ -1029,11 +965,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
"Source length exceeds Target capacity";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
if Source.Length = 0 then
......@@ -1117,103 +1048,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return False;
end Overlap;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
end if;
pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
Process (Container.Nodes (Position.Node).Element);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Set)
is
function Read_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type;
procedure Read_Nodes is
new HT_Ops.Generic_Read (Read_Node);
---------------
-- Read_Node --
---------------
function Read_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is new Generic_Allocate (Read_Element);
------------------
-- Read_Element --
------------------
procedure Read_Element (Node : in out Node_Type) is
begin
Element_Type'Read (Stream, Node.Element);
end Read_Element;
Node : Count_Type;
-- Start of processing for Read_Node
begin
Allocate (Container, Node);
return Node;
end Read_Node;
-- Start of processing for Read
begin
Read_Nodes (Stream, Container);
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
-- Replace --
-------------
......@@ -1230,11 +1064,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
"attempt to replace element not in set";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Container.Nodes (Node).Element := New_Item;
end Replace;
......@@ -1391,11 +1220,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
Iterate (Source);
end Symmetric_Difference;
......@@ -1475,10 +1299,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (set is busy)";
end if;
Iterate (Source);
end Union;
......@@ -1557,47 +1377,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
end;
end Vet;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Set)
is
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type);
pragma Inline (Write_Node);
procedure Write_Nodes is
new HT_Ops.Generic_Write (Write_Node);
----------------
-- Write_Node --
----------------
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type)
is
begin
Element_Type'Write (Stream, Node.Element);
end Write_Node;
-- Start of processing for Write
begin
Write_Nodes (Stream, Container);
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error with "attempt to stream set cursor";
end Write;
package body Generic_Keys is
-----------------------
......@@ -1752,90 +1531,6 @@ package body Ada.Containers.Formal_Hashed_Sets is
Replace_Element (Container, Node, New_Item);
end Replace;
-----------------------------------
-- Update_Element_Preserving_Key --
-----------------------------------
procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type))
is
Indx : Hash_Type;
N : Nodes_Type renames Container.Nodes;
begin
if Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
end if;
pragma Assert
(Vet (Container, Position),
"bad cursor in Update_Element_Preserving_Key");
-- Record bucket now, in case key is changed
Indx := HT_Ops.Index (Container.Buckets, N (Position.Node));
declare
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
Process (E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, Key (E)) then
pragma Assert (Hash (K) = Hash (E));
return;
end if;
end;
-- Key was modified, so remove this node from set
if Container.Buckets (Indx) = Position.Node then
Container.Buckets (Indx) := N (Position.Node).Next;
else
declare
Prev : Count_Type := Container.Buckets (Indx);
begin
while N (Prev).Next /= Position.Node loop
Prev := N (Prev).Next;
if Prev = 0 then
raise Program_Error with
"Position cursor is bad (node not found)";
end if;
end loop;
N (Prev).Next := N (Position.Node).Next;
end;
end if;
Container.Length := Container.Length - 1;
Free (Container, Position.Node);
raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
end Ada.Containers.Formal_Hashed_Sets;
gcc/ada/a-cfhase.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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 --
......@@ -52,7 +52,6 @@
-- See detailed specifications for these subprograms
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
generic
type Element_Type is private;
......@@ -68,8 +67,7 @@ package Ada.Containers.Formal_Hashed_Sets is
pragma Pure;
type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
-- why is this commented out ???
-- pragma Preelaborable_Initialization (Set);
pragma Preelaborable_Initialization (Set);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
......@@ -108,11 +106,6 @@ package Ada.Containers.Formal_Hashed_Sets is
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
......@@ -187,11 +180,6 @@ package Ada.Containers.Formal_Hashed_Sets is
(Left : Element_Type;
Right : Set; CRight : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor));
function Default_Modulus (Capacity : Count_Type) return Hash_Type;
generic
......@@ -222,12 +210,6 @@ package Ada.Containers.Formal_Hashed_Sets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type));
end Generic_Keys;
function Strict_Equal (Left, Right : Set) return Boolean;
......@@ -262,38 +244,13 @@ private
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
type Cursor is record
Node : Count_Type;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := (Node => 0);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Set);
for Set'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Set);
for Set'Read use Read;
Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>);
end Ada.Containers.Formal_Hashed_Sets;
gcc/ada/a-cforma.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, 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- --
......@@ -558,11 +558,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
Insert (Container, Key, New_Item, Position, Inserted);
if not Inserted then
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
declare
N : Node_Type renames Container.Nodes (Position.Node);
begin
......@@ -635,56 +630,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end if;
end Insert;
------------
-- Insert --
------------
procedure Insert
(Container : in out Map;
Key : Key_Type;
Position : out Cursor;
Inserted : out Boolean)
is
function New_Node return Node_Access;
procedure Insert_Post is
new Key_Ops.Generic_Insert_Post (New_Node);
procedure Insert_Sans_Hint is
new Key_Ops.Generic_Conditional_Insert (Insert_Post);
--------------
-- New_Node --
--------------
function New_Node return Node_Access is
procedure Initialize (Node : in out Node_Type);
procedure Allocate_Node is new Generic_Allocate (Initialize);
----------------
-- Initialize --
----------------
procedure Initialize (Node : in out Node_Type) is
begin
Node.Key := Key;
end Initialize;
X : Node_Access;
-- Start of processing for New_Node
begin
Allocate_Node (Container, X);
return X;
end New_Node;
-- Start of processing for Insert
begin
Insert_Sans_Hint (Container, Key, Position.Node, Inserted);
end Insert;
--------------
-- Is_Empty --
--------------
......@@ -720,48 +665,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
return Left < Right.Key;
end Is_Less_Key_Node;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Iterate is
new Tree_Operations.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Container, (Node => Node));
end Process_Node;
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Iterate
begin
B := B + 1;
begin
Local_Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
---------
-- Key --
---------
......@@ -881,11 +784,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Source length exceeds Target capacity";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
loop
......@@ -1014,93 +912,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
end;
end Previous;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
end if;
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Query_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Map)
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is
new Generic_Allocate (Read_Element);
procedure Read_Elements is
new Tree_Operations.Generic_Read (Allocate);
------------------
-- Read_Element --
------------------
procedure Read_Element (Node : in out Node_Type) is
begin
Key_Type'Read (Stream, Node.Key);
Element_Type'Read (Stream, Node.Element);
end Read_Element;
-- Start of processing for Read
begin
Read_Elements (Stream, Container);
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error with "attempt to stream map cursor";
end Read;
-------------
-- Replace --
-------------
......@@ -1119,11 +930,6 @@ package body Ada.Containers.Formal_Ordered_Maps is
raise Constraint_Error with "key not in map";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
declare
N : Node_Type renames Container.Nodes (Node);
begin
......@@ -1148,59 +954,12 @@ package body Ada.Containers.Formal_Ordered_Maps is
"Position cursor of Replace_Element has no element";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (map is locked)";
end if;
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Replace_Element is bad");
Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Map;
Process : not null access procedure (Container : Map;
Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
pragma Inline (Process_Node);
procedure Local_Reverse_Iterate is
new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
begin
Process (Container, (Node => Node));
end Process_Node;
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
begin
B := B + 1;
begin
Local_Reverse_Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
-----------
-- Right --
-----------
......@@ -1305,93 +1064,4 @@ package body Ada.Containers.Formal_Ordered_Maps is
return False;
end Strict_Equal;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : in out Map;
Position : Cursor;
Process : not null access procedure (Key : Key_Type;
Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Update_Element has no element";
end if;
pragma Assert (Vet (Container, Position.Node),
"Position cursor of Update_Element is bad");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
declare
N : Node_Type renames Container.Nodes (Position.Node);
K : Key_Type renames N.Key;
E : Element_Type renames N.Element;
begin
Process (K, E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Map)
is
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type);
pragma Inline (Write_Node);
procedure Write_Nodes is
new Tree_Operations.Generic_Write (Write_Node);
----------------
-- Write_Node --
----------------
procedure Write_Node
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type)
is
begin
Key_Type'Write (Stream, Node.Key);
Element_Type'Write (Stream, Node.Element);
end Write_Node;
-- Start of processing for Write
begin
Write_Nodes (Stream, Container);
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error with "attempt to stream map cursor";
end Write;
end Ada.Containers.Formal_Ordered_Maps;
gcc/ada/a-cforma.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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 --
......@@ -54,7 +54,6 @@
-- See detailed specifications for these subprograms
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
generic
type Key_Type is private;
......@@ -99,18 +98,6 @@ package Ada.Containers.Formal_Ordered_Maps is
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type));
procedure Update_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : in out Element_Type));
procedure Move (Target : in out Map; Source : in out Map);
procedure Insert
......@@ -123,12 +110,6 @@ package Ada.Containers.Formal_Ordered_Maps is
procedure Insert
(Container : in out Map;
Key : Key_Type;
Position : out Cursor;
Inserted : out Boolean);
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
procedure Include
......@@ -183,16 +164,6 @@ package Ada.Containers.Formal_Ordered_Maps is
function Has_Element (Container : Map; Position : Cursor) return Boolean;
procedure Iterate
(Container : Map;
Process :
not null access procedure (Container : Map; Position : Cursor));
procedure Reverse_Iterate
(Container : Map;
Process : not null access
procedure (Container : Map; Position : Cursor));
function Strict_Equal (Left, Right : Map) return Boolean;
-- Strict_Equal returns True if the containers are physically equal, i.e.
-- they are structurally equal (function "=" returns True) and that they
......@@ -234,38 +205,12 @@ private
type Map (Capacity : Count_Type) is
new Tree_Types.Tree_Type (Capacity) with null record;
use Ada.Streams;
type Cursor is record
Node : Node_Access;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
Empty_Map : constant Map := (Capacity => 0, others => <>);
No_Element : constant Cursor := (Node => 0);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Map);
for Map'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Map);
for Map'Read use Read;
Empty_Map : constant Map := (Capacity => 0, others => <>);
end Ada.Containers.Formal_Ordered_Maps;
gcc/ada/a-cforse.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, 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- --
......@@ -807,64 +807,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
end if;
end Replace;
-----------------------------------
-- Update_Element_Preserving_Key --
-----------------------------------
procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor has no element";
end if;
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Update_Element_Preserving_Key");
declare
N : Tree_Types.Nodes_Type renames Container.Nodes;
E : Element_Type renames N (Position.Node).Element;
K : constant Key_Type := Key (E);
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
Process (E);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
if Equivalent_Keys (K, Key (E)) then
return;
end if;
end;
declare
X : constant Count_Type := Position.Node;
begin
Tree_Operations.Delete_Node_Sans_Free (Container, X);
Formal_Ordered_Sets.Free (Container, X);
end;
raise Program_Error with "key was modified";
end Update_Element_Preserving_Key;
end Generic_Keys;
-----------------
......@@ -892,11 +834,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Insert (Container, New_Item, Position, Inserted);
if not Inserted then
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
declare
N : Tree_Types.Nodes_Type renames Container.Nodes;
begin
......@@ -1122,50 +1059,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set);
end Is_Subset;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Set;
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
procedure Local_Iterate is
new Tree_Operations.Generic_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Count_Type) is
begin
Process (Container, (Node => Node));
end Process_Node;
-- Local variables
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of prccessing for Iterate
begin
B := B + 1;
begin
Local_Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
----------
-- Last --
----------
......@@ -1257,11 +1150,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
"Source length exceeds Target capacity";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors of Source (list is busy)";
end if;
Clear (Target);
loop
......@@ -1347,85 +1235,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Position := Previous (Container, Position);
end Previous;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
begin
if not Has_Element (Container, Position) then
raise Constraint_Error with "Position cursor has no element";
end if;
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Query_Element");
declare
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
B := B + 1;
L := L + 1;
begin
Process (Container.Nodes (Position.Node).Element);
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end;
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Set)
is
procedure Read_Element (Node : in out Node_Type);
pragma Inline (Read_Element);
procedure Allocate is
new Generic_Allocate (Read_Element);
procedure Read_Elements is
new Tree_Operations.Generic_Read (Allocate);
------------------
-- Read_Element --
------------------
procedure Read_Element (Node : in out Node_Type) is
begin
Element_Type'Read (Stream, Node.Element);
end Read_Element;
-- Start of processing for Read
begin
Read_Elements (Stream, Container);
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor)
is
begin
raise Program_Error with "attempt to stream set cursor";
end Read;
-------------
-- Replace --
-------------
......@@ -1439,11 +1248,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
"attempt to replace element not in set";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
Container.Nodes (Node).Element := New_Item;
end Replace;
......@@ -1502,11 +1306,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
null;
else
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
NN (Node).Element := Item;
return;
end if;
......@@ -1518,11 +1317,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
elsif Item < NN (Hint).Element then
if Hint = Node then
if Tree.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (set is locked)";
end if;
NN (Node).Element := Item;
return;
end if;
......@@ -1532,7 +1326,7 @@ package body Ada.Containers.Formal_Ordered_Sets is
raise Program_Error with "attempt to replace existing element";
end if;
Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit
Tree_Operations.Delete_Node_Sans_Free (Tree, Node);
Local_Insert_With_Hint
(Tree => Tree,
......@@ -1562,48 +1356,6 @@ package body Ada.Containers.Formal_Ordered_Sets is
Replace_Element (Container, Position.Node, New_Item);
end Replace_Element;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Set;
Process : not null access procedure (Container : Set;
Position : Cursor))
is
procedure Process_Node (Node : Count_Type);
pragma Inline (Process_Node);
procedure Local_Reverse_Iterate is
new Tree_Operations.Generic_Reverse_Iteration (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Count_Type) is
begin
Process (Container, (Node => Node));
end Process_Node;
B : Natural renames Container'Unrestricted_Access.Busy;
-- Start of processing for Reverse_Iterate
begin
B := B + 1;
begin
Local_Reverse_Iterate (Container);
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
-----------
-- Right --
-----------
......@@ -1781,46 +1533,4 @@ package body Ada.Containers.Formal_Ordered_Sets is
end return;
end Union;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Set)
is
procedure Write_Element
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type);
pragma Inline (Write_Element);
procedure Write_Elements is
new Tree_Operations.Generic_Write (Write_Element);
-------------------
-- Write_Element --
-------------------
procedure Write_Element
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type)
is
begin
Element_Type'Write (Stream, Node.Element);
end Write_Element;
-- Start of processing for Write
begin
Write_Elements (Stream, Container);
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor)
is
begin
raise Program_Error with "attempt to stream set cursor";
end Write;
end Ada.Containers.Formal_Ordered_Sets;
gcc/ada/a-cforse.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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 --
......@@ -53,7 +53,6 @@
-- See detailed specifications for these subprograms
private with Ada.Containers.Red_Black_Trees;
private with Ada.Streams;
generic
type Element_Type is private;
......@@ -100,11 +99,6 @@ package Ada.Containers.Formal_Ordered_Sets is
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : in out Set;
Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Move (Target : in out Set; Source : in out Set);
procedure Insert
......@@ -195,16 +189,6 @@ package Ada.Containers.Formal_Ordered_Sets is
function Has_Element (Container : Set; Position : Cursor) return Boolean;
procedure Iterate
(Container : Set;
Process :
not null access procedure (Container : Set; Position : Cursor));
procedure Reverse_Iterate
(Container : Set;
Process : not null access
procedure (Container : Set; Position : Cursor));
generic
type Key_Type (<>) is private;
......@@ -237,12 +221,6 @@ package Ada.Containers.Formal_Ordered_Sets is
function Contains (Container : Set; Key : Key_Type) return Boolean;
procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type));
end Generic_Keys;
function Strict_Equal (Left, Right : Set) return Boolean;
......@@ -280,41 +258,13 @@ private
new Tree_Types.Tree_Type (Capacity) with null record;
use Red_Black_Trees;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
type Cursor is record
Node : Count_Type;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Item : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Item : out Cursor);
for Cursor'Read use Read;
No_Element : constant Cursor := (Node => 0);
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Set);
for Set'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Set);
for Set'Read use Read;
Empty_Set : constant Set := (Capacity => 0, others => <>);
end Ada.Containers.Formal_Ordered_Sets;
gcc/ada/a-cofove.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2010-2013, 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- --
......@@ -37,6 +37,11 @@ package body Ada.Containers.Formal_Vectors is
(Container : Vector;
Position : Count_Type) return Element_Type;
procedure Insert_Space
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1);
---------
-- "&" --
---------
......@@ -256,7 +261,7 @@ package body Ada.Containers.Formal_Vectors is
-- Capacity --
--------------
function Capacity (Container : Vector) return Capacity_Subtype is
function Capacity (Container : Vector) return Count_Type is
begin
return Container.Elements'Length;
end Capacity;
......@@ -267,11 +272,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Clear (Container : in out Vector) is
begin
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
Container.Last := No_Index;
end Clear;
......@@ -293,10 +293,10 @@ package body Ada.Containers.Formal_Vectors is
function Copy
(Source : Vector;
Capacity : Capacity_Subtype := 0) return Vector
Capacity : Count_Type := 0) return Vector
is
LS : constant Count_Type := Length (Source);
C : Capacity_Subtype;
C : Count_Type;
begin
if Capacity = 0 then
......@@ -339,11 +339,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
I_As_Int : constant Int := Int (Index);
Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
......@@ -437,11 +432,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
Index := Int'Base (Container.Last) - Int'Base (Count);
if Index < Index_Type'Pos (Index_Type'First) then
......@@ -607,7 +597,7 @@ package body Ada.Containers.Formal_Vectors is
end if;
declare
L : constant Capacity_Subtype := Length (Container);
L : constant Count_Type := Length (Container);
begin
for J in Count_Type range 1 .. L - 1 loop
if Get_Element (Container, J + 1) <
......@@ -650,16 +640,6 @@ package body Ada.Containers.Formal_Vectors is
-- I think we're missing this check in a-convec.adb... ???
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
I := Length (Target);
Target.Set_Length (I + Length (Source));
......@@ -709,11 +689,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
Sort (Container.Elements (1 .. Length (Container)));
end Sort;
......@@ -807,11 +782,6 @@ package body Ada.Containers.Formal_Vectors is
-- Resolve issue of capacity vs. max index ???
end;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
EA : Elements_Array renames Container.Elements;
......@@ -1055,30 +1025,6 @@ package body Ada.Containers.Formal_Vectors is
Position := Cursor'(True, Index);
end Insert;
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1)
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
begin
Insert (Container, Before, New_Item, Count);
end Insert;
procedure Insert
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1)
is
New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item);
begin
Insert (Container, Before, New_Item, Position, Count);
end Insert;
------------------
-- Insert_Space --
------------------
......@@ -1138,11 +1084,6 @@ package body Ada.Containers.Formal_Vectors is
-- Resolve issue of capacity vs. max index ???
end;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
declare
EA : Elements_Array renames Container.Elements;
......@@ -1166,46 +1107,6 @@ package body Ada.Containers.Formal_Vectors is
Container.Last := New_Last;
end Insert_Space;
procedure Insert_Space
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1)
is
Index : Index_Type'Base;
begin
if Count = 0 then
if not Before.Valid
or else Before.Index > Container.Last
then
Position := No_Element;
else
Position := (True, Before.Index);
end if;
return;
end if;
if not Before.Valid
or else Before.Index > Container.Last
then
if Container.Last = Index_Type'Last then
raise Constraint_Error with
"vector is already at its maximum length";
end if;
Index := Container.Last + 1;
else
Index := Before.Index;
end if;
Insert_Space (Container, Index, Count => Count);
Position := Cursor'(True, Index);
end Insert_Space;
--------------
-- Is_Empty --
--------------
......@@ -1215,34 +1116,6 @@ package body Ada.Containers.Formal_Vectors is
return Last_Index (Container) < Index_Type'First;
end Is_Empty;
-------------
-- Iterate --
-------------
procedure Iterate
(Container : Vector;
Process :
not null access procedure (Container : Vector; Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
begin
B := B + 1;
begin
for Indx in Index_Type'First .. Last_Index (Container) loop
Process (Container, Cursor'(True, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Iterate;
----------
-- Last --
----------
......@@ -1282,13 +1155,13 @@ package body Ada.Containers.Formal_Vectors is
-- Length --
------------
function Length (Container : Vector) return Capacity_Subtype is
function Length (Container : Vector) return Count_Type is
L : constant Int := Int (Last_Index (Container));
F : constant Int := Int (Index_Type'First);
N : constant Int'Base := L - F + 1;
begin
return Capacity_Subtype (N);
return Count_Type (N);
end Length;
----------
......@@ -1328,16 +1201,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Target.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (Target is busy)";
end if;
if Source.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (Source is busy)";
end if;
if N > Target.Capacity then
raise Constraint_Error with -- correct exception here???
"length of Source is greater than capacity of Target";
......@@ -1440,96 +1303,6 @@ package body Ada.Containers.Formal_Vectors is
return No_Element;
end Previous;
-------------------
-- Query_Element --
-------------------
procedure Query_Element
(Container : Vector;
Index : Index_Type;
Process : not null access procedure (Element : Element_Type))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
L : Natural renames V.Lock;
begin
if Index > Last_Index (Container) then
raise Constraint_Error with "Index is out of range";
end if;
B := B + 1;
L := L + 1;
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
begin
Process (Get_Element (V, I));
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end Query_Element;
procedure Query_Element
(Container : Vector;
Position : Cursor;
Process : not null access procedure (Element : Element_Type))
is
begin
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
Query_Element (Container, Position.Index, Process);
end Query_Element;
----------
-- Read --
----------
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Vector)
is
Length : Count_Type'Base;
Last : Index_Type'Base := No_Index;
begin
Clear (Container);
Count_Type'Base'Read (Stream, Length);
if Length < 0 then
raise Program_Error with "stream appears to be corrupt";
end if;
if Length > Container.Capacity then
raise Storage_Error with "not enough capacity"; -- ???
end if;
for J in Count_Type range 1 .. Length loop
Last := Last + 1;
Element_Type'Read (Stream, Container.Elements (J));
Container.Last := Last;
end loop;
end Read;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Position : out Cursor)
is
begin
raise Program_Error with "attempt to stream vector cursor";
end Read;
---------------------
-- Replace_Element --
---------------------
......@@ -1544,11 +1317,6 @@ package body Ada.Containers.Formal_Vectors is
raise Constraint_Error with "Index is out of range";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
......@@ -1572,11 +1340,6 @@ package body Ada.Containers.Formal_Vectors is
raise Constraint_Error with "Position cursor is out of range";
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
declare
II : constant Int'Base := Int (Position.Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
......@@ -1591,11 +1354,11 @@ package body Ada.Containers.Formal_Vectors is
procedure Reserve_Capacity
(Container : in out Vector;
Capacity : Capacity_Subtype)
Capacity : Count_Type)
is
begin
if Capacity > Container.Capacity then
raise Constraint_Error; -- ???
raise Constraint_Error with "Capacity is out of range";
end if;
end Reserve_Capacity;
......@@ -1609,11 +1372,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
declare
I, J : Count_Type;
E : Elements_Array renames Container.Elements;
......@@ -1699,34 +1457,6 @@ package body Ada.Containers.Formal_Vectors is
return No_Index;
end Reverse_Find_Index;
---------------------
-- Reverse_Iterate --
---------------------
procedure Reverse_Iterate
(Container : Vector;
Process : not null access procedure (Container : Vector;
Position : Cursor))
is
V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy;
begin
B := B + 1;
begin
for Indx in reverse Index_Type'First .. Last_Index (Container) loop
Process (Container, Cursor'(True, Indx));
end loop;
exception
when others =>
B := B - 1;
raise;
end;
B := B - 1;
end Reverse_Iterate;
-----------
-- Right --
-----------
......@@ -1757,18 +1487,13 @@ package body Ada.Containers.Formal_Vectors is
procedure Set_Length
(Container : in out Vector;
Length : Capacity_Subtype)
Length : Count_Type)
is
begin
if Length = Formal_Vectors.Length (Container) then
return;
end if;
if Container.Busy > 0 then
raise Program_Error with
"attempt to tamper with elements (vector is busy)";
end if;
if Length > Container.Capacity then
raise Constraint_Error; -- ???
end if;
......@@ -1799,11 +1524,6 @@ package body Ada.Containers.Formal_Vectors is
return;
end if;
if Container.Lock > 0 then
raise Program_Error with
"attempt to tamper with cursors (vector is locked)";
end if;
declare
II : constant Int'Base := Int (I) - Int (No_Index);
JJ : constant Int'Base := Int (J) - Int (No_Index);
......@@ -1865,32 +1585,9 @@ package body Ada.Containers.Formal_Vectors is
-- To_Vector --
---------------
function To_Vector (Length : Capacity_Subtype) return Vector is
begin
if Length = 0 then
return Empty_Vector;
end if;
declare
First : constant Int := Int (Index_Type'First);
Last_As_Int : constant Int'Base := First + Int (Length) - 1;
Last : Index_Type;
begin
if Last_As_Int > Index_Type'Pos (Index_Type'Last) then
raise Constraint_Error with "Length is out of range"; -- ???
end if;
Last := Index_Type (Last_As_Int);
return (Length, (others => <>), Last => Last,
others => <>);
end;
end To_Vector;
function To_Vector
(New_Item : Element_Type;
Length : Capacity_Subtype) return Vector
Length : Count_Type) return Vector
is
begin
if Length = 0 then
......@@ -1914,78 +1611,4 @@ package body Ada.Containers.Formal_Vectors is
end;
end To_Vector;
--------------------
-- Update_Element --
--------------------
procedure Update_Element
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type))
is
B : Natural renames Container.Busy;
L : Natural renames Container.Lock;
begin
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
B := B + 1;
L := L + 1;
declare
II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II);
begin
Process (Container.Elements (I));
exception
when others =>
L := L - 1;
B := B - 1;
raise;
end;
L := L - 1;
B := B - 1;
end Update_Element;
procedure Update_Element
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type))
is
begin
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
Update_Element (Container, Position.Index, Process);
end Update_Element;
-----------
-- Write --
-----------
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Vector)
is
begin
Count_Type'Base'Write (Stream, Length (Container));
for J in 1 .. Length (Container) loop
Element_Type'Write (Stream, Container.Elements (J));
end loop;
end Write;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Position : Cursor)
is
begin
raise Program_Error with "attempt to stream vector cursor";
end Write;
end Ada.Containers.Formal_Vectors;
gcc/ada/a-cofove.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2013, 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 --
......@@ -55,7 +55,6 @@
-- iterate over containers. Left returns the part of the container already
-- scanned and Right the part not scanned yet.
private with Ada.Streams;
with Ada.Containers;
use Ada.Containers;
......@@ -72,21 +71,9 @@ package Ada.Containers.Formal_Vectors is
range Index_Type'First - 1 ..
Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
-- ??? i don't think we can do this...
-- TODO: we need the ARG to either figure out how to declare this subtype,
-- or eliminate the requirement that it be present.
-- subtype Capacity_Subtype is Count_Type -- correct name???
-- range 0 .. Count_Type'Max (0,
-- Index_Type'Pos (Index_Type'Last) -
-- Index_Type'Pos (Index_Type'First) + 1);
--
-- so for now:
subtype Capacity_Subtype is Count_Type;
No_Index : constant Extended_Index := Extended_Index'First;
type Vector (Capacity : Capacity_Subtype) is tagged private;
-- pragma Preelaborable_Initialization (Vector);
type Vector (Capacity : Count_Type) is tagged private;
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
......@@ -97,11 +84,9 @@ package Ada.Containers.Formal_Vectors is
function "=" (Left, Right : Vector) return Boolean;
function To_Vector (Length : Capacity_Subtype) return Vector;
function To_Vector
(New_Item : Element_Type;
Length : Capacity_Subtype) return Vector;
Length : Count_Type) return Vector;
function "&" (Left, Right : Vector) return Vector;
......@@ -111,17 +96,17 @@ package Ada.Containers.Formal_Vectors is
function "&" (Left, Right : Element_Type) return Vector;
function Capacity (Container : Vector) return Capacity_Subtype;
function Capacity (Container : Vector) return Count_Type;
procedure Reserve_Capacity
(Container : in out Vector;
Capacity : Capacity_Subtype);
Capacity : Count_Type);
function Length (Container : Vector) return Capacity_Subtype;
function Length (Container : Vector) return Count_Type;
procedure Set_Length
(Container : in out Vector;
Length : Capacity_Subtype);
Length : Count_Type);
function Is_Empty (Container : Vector) return Boolean;
......@@ -131,7 +116,7 @@ package Ada.Containers.Formal_Vectors is
function Copy
(Source : Vector;
Capacity : Capacity_Subtype := 0) return Vector;
Capacity : Count_Type := 0) return Vector;
function To_Cursor
(Container : Vector;
......@@ -157,26 +142,6 @@ package Ada.Containers.Formal_Vectors is
Position : Cursor;
New_Item : Element_Type);
procedure Query_Element
(Container : Vector;
Index : Index_Type;
Process : not null access procedure (Element : Element_Type));
procedure Query_Element
(Container : Vector;
Position : Cursor;
Process : not null access procedure (Element : Element_Type));
procedure Update_Element
(Container : in out Vector;
Index : Index_Type;
Process : not null access procedure (Element : in out Element_Type));
procedure Update_Element
(Container : in out Vector;
Position : Cursor;
Process : not null access procedure (Element : in out Element_Type));
procedure Move (Target : in out Vector; Source : in out Vector);
procedure Insert
......@@ -214,17 +179,6 @@ package Ada.Containers.Formal_Vectors is
Position : out Cursor;
Count : Count_Type := 1);
procedure Insert
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1);
procedure Insert
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1);
procedure Prepend
(Container : in out Vector;
New_Item : Vector);
......@@ -243,17 +197,6 @@ package Ada.Containers.Formal_Vectors is
New_Item : Element_Type;
Count : Count_Type := 1);
procedure Insert_Space
(Container : in out Vector;
Before : Extended_Index;
Count : Count_Type := 1);
procedure Insert_Space
(Container : in out Vector;
Before : Cursor;
Position : out Cursor;
Count : Count_Type := 1);
procedure Delete
(Container : in out Vector;
Index : Extended_Index;
......@@ -324,16 +267,6 @@ package Ada.Containers.Formal_Vectors is
function Has_Element (Container : Vector; Position : Cursor) return Boolean;
procedure Iterate
(Container : Vector;
Process : not null access
procedure (Container : Vector; Position : Cursor));
procedure Reverse_Iterate
(Container : Vector;
Process : not null access
procedure (Container : Vector; Position : Cursor));
generic
with function "<" (Left, Right : Element_Type) return Boolean is <>;
package Generic_Sorting is
......@@ -357,8 +290,6 @@ private
pragma Inline (Element);
pragma Inline (First_Element);
pragma Inline (Last_Element);
pragma Inline (Query_Element);
pragma Inline (Update_Element);
pragma Inline (Replace_Element);
pragma Inline (Contains);
pragma Inline (Next);
......@@ -367,44 +298,16 @@ private
type Elements_Array is array (Count_Type range <>) of Element_Type;
function "=" (L, R : Elements_Array) return Boolean is abstract;
type Vector (Capacity : Capacity_Subtype) is tagged record
type Vector (Capacity : Count_Type) is tagged record
Elements : Elements_Array (1 .. Capacity);
Last : Extended_Index := No_Index;
Busy : Natural := 0;
Lock : Natural := 0;
end record;
use Ada.Streams;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Container : Vector);
for Vector'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Container : out Vector);
for Vector'Read use Read;
type Cursor is record
Valid : Boolean := True;
Index : Index_Type := Index_Type'First;
end record;
procedure Write
(Stream : not null access Root_Stream_Type'Class;
Position : Cursor);
for Cursor'Write use Write;
procedure Read
(Stream : not null access Root_Stream_Type'Class;
Position : out Cursor);
for Cursor'Read use Read;
Empty_Vector : constant Vector := (Capacity => 0, others => <>);
No_Element : constant Cursor := (Valid => False, Index => Index_Type'First);
......
gcc/ada/checks.adb
......@@ -2502,8 +2502,8 @@ package body Checks is
-- Here for normal case of predicate active
else
-- If the type has a static predicate and the expression is also
-- static, see if the expression satisfies the predicate.
-- If the type has a static predicate and the expression is known
-- at compile time, see if the expression satisfies the predicate.
Check_Expression_Against_Static_Predicate (N, Typ);
......
gcc/ada/exp_attr.adb
......@@ -2741,20 +2741,20 @@ package body Exp_Attr is
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
-- In Ada 2005 (or later) if we have the standard nondefault
-- bit order, then we return the original value as given in
-- the component clause (RM 2005 13.5.2(3/2)).
-- In Ada 2005 (or later) if we have the non-default bit order, then
-- we return the original value as given in the component clause
-- (RM 2005 13.5.2(3/2)).
if Present (Component_Clause (CE))
and then Ada_Version >= Ada_2005
and then not Reverse_Bit_Order (Scope (CE))
and then Reverse_Bit_Order (Scope (CE))
then
Rewrite (N,
Make_Integer_Literal (Loc,
Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
Analyze_And_Resolve (N, Typ);
-- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
-- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
-- rewrite with normalized value if we know it statically.
elsif Known_Static_Component_Bit_Offset (CE) then
......@@ -3321,20 +3321,20 @@ package body Exp_Attr is
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
-- In Ada 2005 (or later) if we have the standard nondefault
-- bit order, then we return the original value as given in
-- the component clause (RM 2005 13.5.2(4/2)).
-- In Ada 2005 (or later) if we have the non-default bit order, then
-- we return the original value as given in the component clause
-- (RM 2005 13.5.2(3/2)).
if Present (Component_Clause (CE))
and then Ada_Version >= Ada_2005
and then not Reverse_Bit_Order (Scope (CE))
and then Reverse_Bit_Order (Scope (CE))
then
Rewrite (N,
Make_Integer_Literal (Loc,
Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
Analyze_And_Resolve (N, Typ);
-- Otherwise (Ada 83/95 or Ada 2005 or later with reverse bit order),
-- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
-- rewrite with normalized value if we know it statically.
elsif Known_Static_Component_Bit_Offset (CE)
......@@ -4243,18 +4243,18 @@ package body Exp_Attr is
begin
if Present (Component_Clause (CE)) then
-- In Ada 2005 (or later) if we have the standard nondefault
-- bit order, then we return the original value as given in
-- the component clause (RM 2005 13.5.2(2/2)).
-- In Ada 2005 (or later) if we have the non-default bit order,
-- then we return the original value as given in the component
-- clause (RM 2005 13.5.2(2/2)).
if Ada_Version >= Ada_2005
and then not Reverse_Bit_Order (Scope (CE))
and then Reverse_Bit_Order (Scope (CE))
then
Rewrite (N,
Make_Integer_Literal (Loc,
Intval => Expr_Value (Position (Component_Clause (CE)))));
-- Otherwise (Ada 83 or 95, or reverse bit order specified in
-- Otherwise (Ada 83 or 95, or default bit order specified in
-- later Ada version), return the normalized value.
else
......
gcc/ada/sem_ch3.adb
......@@ -3277,8 +3277,8 @@ package body Sem_Ch3 is
or else
Is_Partially_Initialized_Type (T, Include_Implicit => False))
then
-- If the type has a static predicate and the expression is also
-- static, see if the expression satisfies the predicate.
-- If the type has a static predicate and the expression is known at
-- compile time, see if the expression satisfies the predicate.
if Present (E) then
Check_Expression_Against_Static_Predicate (E, T);
......@@ -3297,8 +3297,7 @@ package body Sem_Ch3 is
if Is_String_Type (T) and then not Constant_Present (N) then
Check_SPARK_Restriction
("declaration of object of unconstrained type not allowed",
N);
("declaration of object of unconstrained type not allowed", N);
end if;
-- Nothing to do in deferred constant case
......
gcc/ada/sem_prag.adb
......@@ -202,7 +202,11 @@ package body Sem_Prag is
Check_Duplicates : Boolean := False) return Node_Id;
-- Find the declaration of the related subprogram subject to pragma Prag.
-- If flag Check_Duplicates is set, the routine emits errors concerning
-- duplicate pragmas.
-- duplicate pragmas. If a related subprogram is found, then either the
-- corresponding N_Subprogram_Declaration node is returned, or, if the
-- pragma applies to a subprogram body, then the N_Subprogram_Body node
-- is returned. Note that in the latter case, no check is made to ensure
-- that there is no separate declaration of the subprogram.
function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
-- If Def_Id refers to a renamed subprogram, then the base subprogram (the
......@@ -10043,7 +10047,6 @@ package body Sem_Prag is
begin
GNAT_Pragma;
S14_Pragma;
Check_Arg_Count (1);
-- Ensure the proper placement of the pragma. Contract_Cases must
......@@ -18113,63 +18116,83 @@ package body Sem_Prag is
is
Context : constant Node_Id := Parent (Prag);
Nam : constant Name_Id := Pragma_Name (Prag);
Decl : Node_Id;
Elmt : Node_Id;
Subp_Decl : Node_Id;
begin
-- The pragma is a byproduct of an aspect
pragma Assert (Nkind (Prag) = N_Pragma);
-- If the pragma comes from an aspect, then what we want is the
-- declaration to which the aspect is attached, i.e. its parent.
if Present (Corresponding_Aspect (Prag)) then
Subp_Decl := Parent (Corresponding_Aspect (Prag));
return Parent (Corresponding_Aspect (Prag));
end if;
-- The pragma is associated with a library-level subprogram
-- Otherwise the pragma must be a list element, and the first thing to
-- do is to position past any previous pragmas or generated code. What
-- we are doing here is looking for the preceding declaration. This is
-- also where we will check for a duplicate pragma.
elsif Nkind (Context) = N_Compilation_Unit_Aux then
Subp_Decl := Unit (Parent (Context));
pragma Assert (Is_List_Member (Prag));
-- The pragma appears inside the declarative part of a subprogram body
Elmt := Prag;
loop
Elmt := Prev (Elmt);
exit when No (Elmt);
elsif Nkind (Context) = N_Subprogram_Body then
Subp_Decl := Context;
-- Typically want we will want is the declaration original node. But
-- for the generic subprogram case, don't go to to the original node,
-- which is the unanalyzed tree: we need to attach the pre- and post-
-- conditions to the analyzed version at this point. They propagate
-- to the original tree when analyzing the corresponding body.
-- The pragma appears someplace after its related subprogram. Inspect
-- all previous declarations for a suitable candidate.
if Nkind (Elmt) not in N_Generic_Declaration then
Subp_Decl := Original_Node (Elmt);
else
Subp_Decl := Elmt;
end if;
else
Decl := Prag;
Subp_Decl := Empty;
while Present (Prev (Decl)) loop
Decl := Prev (Decl);
-- Skip prior pragmas
if Nkind (Decl) in N_Generic_Declaration then
Subp_Decl := Decl;
else
Subp_Decl := Original_Node (Decl);
if Nkind (Subp_Decl) = N_Pragma then
if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then
Error_Msg_Name_1 := Nam;
Error_Msg_Sloc := Sloc (Subp_Decl);
Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
end if;
-- Skip prior pragmas
-- Skip internally generated code
if Nkind (Subp_Decl) = N_Pragma then
if Check_Duplicates and then Pragma_Name (Subp_Decl) = Nam then
Error_Msg_Name_1 := Nam;
Error_Msg_Sloc := Sloc (Subp_Decl);
Error_Msg_N ("pragma % duplicates pragma declared #", Prag);
end if;
elsif not Comes_From_Source (Subp_Decl) then
null;
-- Skip internally generated code
-- Otherwise we have a declaration to return
elsif not Comes_From_Source (Subp_Decl) then
null;
else
return Subp_Decl;
end if;
end loop;
-- The nearest preceding declaration is the related subprogram
-- We fell through, which means there was no declaration preceding the
-- pragma (either it was the first element of the list, or we only had
-- other pragmas and generated code before it).
else
exit;
end if;
end loop;
end if;
-- The pragma is associated with a library-level subprogram
if Nkind (Context) = N_Compilation_Unit_Aux then
return Unit (Parent (Context));
return Subp_Decl;
-- The pragma appears inside the declarative part of a subprogram body
elsif Nkind (Context) = N_Subprogram_Body then
return Context;
-- Otherwise no subprogram found, return original pragma
else
return Prag;
end if;
end Find_Related_Subprogram;
-------------------------
......
gcc/ada/sem_util.adb
......@@ -1301,11 +1301,11 @@ package body Sem_Util is
Typ : Entity_Id)
is
begin
-- When both the predicate and the expression are static, evaluate the
-- check at compile time. A type becomes non-static when it has aspect
-- Dynamic_Predicate.
-- When the predicate is static and the value of the expression is known
-- at compile time, evaluate the predicate check. A type is non-static
-- when it has aspect Dynamic_Predicate.
if Is_OK_Static_Expression (Expr)
if Compile_Time_Known_Value (Expr)
and then Has_Predicates (Typ)
and then Present (Static_Predicate (Typ))
and then not Has_Dynamic_Predicate_Aspect (Typ)
......
gcc/ada/sem_util.ads
......@@ -195,9 +195,9 @@ package Sem_Util is
(Expr : Node_Id;
Typ : Entity_Id);
-- Determine whether an arbitrary expression satisfies the static predicate
-- of a type. The routine does nothing if Expr is non-static or Typ lacks a
-- static predicate, otherwise it may emit a warning if the expression is
-- prohibited by the predicate.
-- of a type. The routine does nothing if Expr is not known at compile time
-- or Typ lacks a static predicate, otherwise it may emit a warning if the
-- expression is prohibited by the predicate.
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
-- Verify that the full declaration of type T has been seen. If not, place
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment