mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-22 22:51:32 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-10-26  Matthew Heaney  <heaney@adacore.com>

	* Makefile.rtl, impunit.adb: Add bounded hashed set and bounded hashed
	map containers.
	* a-cohata.ads: Add declaration of generic package for bounded hash
	table types.
	* a-chtgbo.ads, a-chtgbo.adb, a-chtgbk.ads, a-chtgbk.adb, a-cbhase.ads,
	a-cbhase.adb, a-cbhama.ads, a-cbhama.adb: New files.

2010-10-26  Ed Schonberg  <schonberg@adacore.com>

	* sem_warn.adb: Improve warning message on overlapping actuals.

2010-10-26  Thomas Quinot  <quinot@adacore.com>

	* sem_ch4.adb, exp_dist.adb: Minor reformatting.

2010-10-26  Vincent Celier  <celier@adacore.com>

	* makeusg.adb (Makeusg): Add lines for switches -vl, -vm and -vh.

2010-10-26  Robert Dewar  <dewar@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Move generation of
	predicate check to analyzer, since too much rewriting occurs in the
	analyzer.
	* sem_ch13.adb (Build_Predicate_Function): Change calling sequence, and
	change the order in which things are done to fix several errors in
	dealing with qualification of the type name.
	(Build_Static_Predicate): Built static predicate after full analysis
	of the body. This is necessary to fix several problems.
	* sem_ch3.adb (Analyze_Object_Declaration): Move predicate check here
	from expander, since too much expansion occurs in the analyzer to leave
	it that late.
	(Analyze_Object_Declaration): Change parameter Include_Null to new name
	Include_Implicit in Is_Partially_Initialized_Type call.
	(Analyze_Subtype_Declaration): Make sure predicates are proapagated in
	some strange cases of internal subtype generation.
	* sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type): Change
	Include_Null to Include_Implicit, now includes the case of
	discriminants.

2010-10-26  Sergey Rybin  <rybin@adacore.com>

	* gnat_rm.texi: Revise the documentation for pragma Eliminate.

From-SVN: r165939
This commit is contained in:
Arnaud Charlet 2010-10-26 12:42:02 +02:00
parent 143eac1265
commit f2acf80cab
22 changed files with 4978 additions and 220 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
gcc/ada/ChangeLog
View File

@ -1,3 +1,49 @@
2010-10-26 Matthew Heaney <heaney@adacore.com>
* Makefile.rtl, impunit.adb: Add bounded hashed set and bounded hashed
map containers.
* a-cohata.ads: Add declaration of generic package for bounded hash
table types.
* a-chtgbo.ads, a-chtgbo.adb, a-chtgbk.ads, a-chtgbk.adb, a-cbhase.ads,
a-cbhase.adb, a-cbhama.ads, a-cbhama.adb: New files.
2010-10-26 Ed Schonberg <schonberg@adacore.com>
* sem_warn.adb: Improve warning message on overlapping actuals.
2010-10-26 Thomas Quinot <quinot@adacore.com>
* sem_ch4.adb, exp_dist.adb: Minor reformatting.
2010-10-26 Vincent Celier <celier@adacore.com>
* makeusg.adb (Makeusg): Add lines for switches -vl, -vm and -vh.
2010-10-26 Robert Dewar <dewar@adacore.com>
* exp_ch3.adb (Expand_N_Object_Declaration): Move generation of
predicate check to analyzer, since too much rewriting occurs in the
analyzer.
* sem_ch13.adb (Build_Predicate_Function): Change calling sequence, and
change the order in which things are done to fix several errors in
dealing with qualification of the type name.
(Build_Static_Predicate): Built static predicate after full analysis
of the body. This is necessary to fix several problems.
* sem_ch3.adb (Analyze_Object_Declaration): Move predicate check here
from expander, since too much expansion occurs in the analyzer to leave
it that late.
(Analyze_Object_Declaration): Change parameter Include_Null to new name
Include_Implicit in Is_Partially_Initialized_Type call.
(Analyze_Subtype_Declaration): Make sure predicates are proapagated in
some strange cases of internal subtype generation.
* sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type): Change
Include_Null to Include_Implicit, now includes the case of
discriminants.
2010-10-26 Sergey Rybin <rybin@adacore.com>
* gnat_rm.texi: Revise the documentation for pragma Eliminate.
2010-10-26 Matthew Heaney <heaney@adacore.com>
* Makefile.rtl, impunit.adb: Added bounded list container.

4
gcc/ada/Makefile.rtl
View File

@ -86,6 +86,8 @@ GNATRTL_NONTASKING_OBJS= \
a-calend$(objext) \
a-calfor$(objext) \
a-catizo$(objext) \
a-cbhama$(objext) \
a-cbhase$(objext) \
a-cborse$(objext) \
a-cbdlli$(objext) \
a-cborma$(objext) \
@ -98,6 +100,8 @@ GNATRTL_NONTASKING_OBJS= \
a-charac$(objext) \
a-chlat1$(objext) \
a-chlat9$(objext) \
a-chtgbo$(objext) \
a-chtgbk$(objext) \
a-chtgke$(objext) \
a-chtgop$(objext) \
a-chzla1$(objext) \

1068
gcc/ada/a-cbhama.adb Normal file
View File

File diff suppressed because it is too large Load Diff

343
gcc/ada/a-cbhama.ads Normal file
View File

@ -0,0 +1,343 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2010, 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
generic
type Key_Type is private;
type Element_Type is private;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Bounded_Hashed_Maps is
pragma Pure;
pragma Remote_Types;
type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
pragma Preelaborable_Initialization (Map);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_Map : constant Map;
-- Map objects declared without an initialization expression are
-- initialized to the value Empty_Map.
No_Element : constant Cursor;
-- Cursor objects declared without an initialization expression are
-- initialized to the value No_Element.
function "=" (Left, Right : Map) return Boolean;
-- For each key/element pair in Left, equality attempts to find the key in
-- Right; if a search fails the equality returns False. The search works by
-- calling Hash to find the bucket in the Right map that corresponds to the
-- Left key. If bucket is non-empty, then equality calls Equivalent_Keys
-- to compare the key (in Left) to the key of each node in the bucket (in
-- Right); if the keys are equivalent, then the equality test for this
-- key/element pair (in Left) completes by calling the element equality
-- operator to compare the element (in Left) to the element of the node
-- (in Right) whose key matched.
function Capacity (Container : Map) return Count_Type;
-- Returns the current capacity of the map. Capacity is the maximum length
-- before which rehashing in guaranteed not to occur.
procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type);
-- If the value of the Capacity actual parameter is less or equal to
-- Container.Capacity, then the operation has no effect. Otherwise it
-- raises Capacity_Error (as no expansion of capacity is possible for a
-- bounded form).
function Default_Modulus (Capacity : Count_Type) return Hash_Type;
-- Returns a modulus value (hash table size) which is optimal for the
-- specified capacity (which corresponds to the maximum number of items).
function Length (Container : Map) return Count_Type;
-- Returns the number of items in the map
function Is_Empty (Container : Map) return Boolean;
-- Equivalent to Length (Container) = 0
procedure Clear (Container : in out Map);
-- Removes all of the items from the map
function Key (Position : Cursor) return Key_Type;
-- Returns the key of the node designated by the cursor
function Element (Position : Cursor) return Element_Type;
-- Returns the element of the node designated by the cursor
procedure Replace_Element
(Container : in out Map;
Position : Cursor;
New_Item : Element_Type);
-- Assigns the value New_Item to the element designated by the cursor
procedure Query_Element
(Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : Element_Type));
-- Calls Process with the key and element (both having only a constant
-- view) of the node designed by the cursor.
procedure Update_Element
(Container : in out Map;
Position : Cursor;
Process : not null access
procedure (Key : Key_Type; Element : in out Element_Type));
-- Calls Process with the key (with only a constant view) and element (with
-- a variable view) of the node designed by the cursor.
procedure Assign (Target : in out Map; Source : Map);
-- If Target denotes the same object as Source, then the operation has no
-- effect. If the Target capacity is less then the Source length, then
-- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
-- copies the (active) elements from Source to Target.
function Copy
(Source : Map;
Capacity : Count_Type := 0;
Modulus : Hash_Type := 0) return Map;
-- Constructs a new set object whose elements correspond to Source. If the
-- Capacity parameter is 0, then the capacity of the result is the same as
-- the length of Source. If the Capacity parameter is equal or greater than
-- the length of Source, then the capacity of the result is the specified
-- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
-- is 0, then the modulus of the result is the value returned by a call to
-- Default_Modulus with the capacity parameter determined as above;
-- otherwise the modulus of the result is the specified value.
procedure Move (Target : in out Map; Source : in out Map);
-- Clears Target (if it's not empty), and then moves (not copies) the
-- buckets array and nodes from Source to Target.
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean);
-- Conditionally inserts New_Item into the map. If Key is already in the
-- map, then Inserted returns False and Position designates the node
-- containing the existing key/element pair (neither of which is modified).
-- If Key is not already in the map, the Inserted returns True and Position
-- designates the newly-inserted node container Key and New_Item. The
-- search for the key works as follows. Hash is called to determine Key's
-- bucket; if the bucket is non-empty, then Equivalent_Keys is called to
-- compare Key to each node in that bucket. If the bucket is empty, or
-- there were no matching keys in the bucket, the search "fails" and the
-- key/item pair is inserted in the map (and Inserted returns True);
-- otherwise, the search "succeeds" (and Inserted returns False).
procedure Insert
(Container : in out Map;
Key : Key_Type;
Position : out Cursor;
Inserted : out Boolean);
-- The same as the (conditional) Insert that accepts an element parameter,
-- with the difference that if Inserted returns True, then the element of
-- the newly-inserted node is initialized to its default value.
procedure Insert
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
-- Attempts to insert Key into the map, performing the usual search (which
-- involves calling both Hash and Equivalent_Keys); if the search succeeds
-- (because Key is already in the map), then it raises Constraint_Error.
-- (This version of Insert is similar to Replace, but having the opposite
-- exception behavior. It is intended for use when you want to assert that
-- Key is not already in the map.)
procedure Include
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
-- Attempts to insert Key into the map. If Key is already in the map, then
-- both the existing key and element are assigned the values of Key and
-- New_Item, respectively. (This version of Insert only raises an exception
-- if cursor tampering occurs. It is intended for use when you want to
-- insert the key/element pair in the map, and you don't care whether Key
-- is already present.)
procedure Replace
(Container : in out Map;
Key : Key_Type;
New_Item : Element_Type);
-- Searches for Key in the map; if the search fails (because Key was not in
-- the map), then it raises Constraint_Error. Otherwise, both the existing
-- key and element are assigned the values of Key and New_Item rsp. (This
-- is similar to Insert, but with the opposite exception behavior. It is to
-- be used when you want to assert that Key is already in the map.)
procedure Exclude (Container : in out Map; Key : Key_Type);
-- Searches for Key in the map, and if found, removes its node from the map
-- and then deallocates it. The search works as follows. The operation
-- calls Hash to determine the key's bucket; if the bucket is not empty, it
-- calls Equivalent_Keys to compare Key to each key in the bucket. (This is
-- the deletion analog of Include. It is intended for use when you want to
-- remove the item from the map, but don't care whether the key is already
-- in the map.)
procedure Delete (Container : in out Map; Key : Key_Type);
-- Searches for Key in the map (which involves calling both Hash and
-- Equivalent_Keys). If the search fails, then the operation raises
-- Constraint_Error. Otherwise it removes the node from the map and then
-- deallocates it. (This is the deletion analog of non-conditional
-- Insert. It is intended for use when you want to assert that the item is
-- already in the map.)
procedure Delete (Container : in out Map; Position : in out Cursor);
-- Removes the node designated by Position from the map, and then
-- deallocates the node. The operation calls Hash to determine the bucket,
-- and then compares Position to each node in the bucket until there's a
-- match (it does not call Equivalent_Keys).
function First (Container : Map) return Cursor;
-- Returns a cursor that designates the first non-empty bucket, by
-- searching from the beginning of the buckets array.
function Next (Position : Cursor) return Cursor;
-- Returns a cursor that designates the node that follows the current one
-- designated by Position. If Position designates the last node in its
-- bucket, the operation calls Hash to compute the index of this bucket,
-- and searches the buckets array for the first non-empty bucket, starting
-- from that index; otherwise, it simply follows the link to the next node
-- in the same bucket.
procedure Next (Position : in out Cursor);
-- Equivalent to Position := Next (Position)
function Find (Container : Map; Key : Key_Type) return Cursor;
-- Searches for Key in the map. Find calls Hash to determine the key's
-- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare
-- Key to each key in the bucket. If the search succeeds, Find returns a
-- cursor designating the matching node; otherwise, it returns No_Element.
function Contains (Container : Map; Key : Key_Type) return Boolean;
-- Equivalent to Find (Container, Key) /= No_Element
function Element (Container : Map; Key : Key_Type) return Element_Type;
-- Equivalent to Element (Find (Container, Key))
function Has_Element (Position : Cursor) return Boolean;
-- Equivalent to Position /= No_Element
function Equivalent_Keys (Left, Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Keys with the keys of the nodes
-- designated by cursors Left and Right.
function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean;
-- Returns the result of calling Equivalent_Keys with key of the node
-- designated by Left and key Right.
function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Keys with key Left and the node
-- designated by Right.
procedure Iterate
(Container : Map;
Process : not null access procedure (Position : Cursor));
-- Calls Process for each node in the map
private
-- pragma Inline ("=");
pragma Inline (Length);
pragma Inline (Is_Empty);
pragma Inline (Clear);
pragma Inline (Key);
pragma Inline (Element);
pragma Inline (Move);
pragma Inline (Contains);
pragma Inline (Capacity);
pragma Inline (Reserve_Capacity);
pragma Inline (Has_Element);
pragma Inline (Equivalent_Keys);
pragma Inline (Next);
type Node_Type is record
Key : Key_Type;
Element : Element_Type;
Next : Count_Type;
end record;
package HT_Types is
new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
type Map (Capacity : Count_Type; Modulus : Hash_Type) is
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
Container : Map_Access;
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;
No_Element : constant Cursor := (Container => null, Node => 0);
Empty_Map : constant Map :=
(Hash_Table_Type with Capacity => 0, Modulus => 0);
end Ada.Containers.Bounded_Hashed_Maps;

1737
gcc/ada/a-cbhase.adb Normal file
View File

File diff suppressed because it is too large Load Diff

466
gcc/ada/a-cbhase.ads Normal file
View File

@ -0,0 +1,466 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2010, 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 --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
private with Ada.Containers.Hash_Tables;
private with Ada.Streams;
generic
type Element_Type is private;
with function Hash (Element : Element_Type) return Hash_Type;
with function Equivalent_Elements
(Left, Right : Element_Type) return Boolean;
with function "=" (Left, Right : Element_Type) return Boolean is <>;
package Ada.Containers.Bounded_Hashed_Sets is
pragma Pure;
pragma Remote_Types;
type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
pragma Preelaborable_Initialization (Set);
type Cursor is private;
pragma Preelaborable_Initialization (Cursor);
Empty_Set : constant Set;
-- Set objects declared without an initialization expression are
-- initialized to the value Empty_Set.
No_Element : constant Cursor;
-- Cursor objects declared without an initialization expression are
-- initialized to the value No_Element.
function "=" (Left, Right : Set) return Boolean;
-- For each element in Left, set equality attempts to find the equal
-- element in Right; if a search fails, then set equality immediately
-- returns False. The search works by calling Hash to find the bucket in
-- the Right set that corresponds to the Left element. If the bucket is
-- non-empty, the search calls the generic formal element equality operator
-- to compare the element (in Left) to the element of each node in the
-- bucket (in Right); the search terminates when a matching node in the
-- bucket is found, or the nodes in the bucket are exhausted. (Note that
-- element equality is called here, not Equivalent_Elements. Set equality
-- is the only operation in which element equality is used. Compare set
-- equality to Equivalent_Sets, which does call Equivalent_Elements.)
function Equivalent_Sets (Left, Right : Set) return Boolean;
-- Similar to set equality, with the difference that the element in Left is
-- compared to the elements in Right using the generic formal
-- Equivalent_Elements operation instead of element equality.
function To_Set (New_Item : Element_Type) return Set;
-- Constructs a singleton set comprising New_Element. To_Set calls Hash to
-- determine the bucket for New_Item.
function Capacity (Container : Set) return Count_Type;
-- Returns the current capacity of the set. Capacity is the maximum length
-- before which rehashing in guaranteed not to occur.
procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type);
-- If the value of the Capacity actual parameter is less or equal to
-- Container.Capacity, then the operation has no effect. Otherwise it
-- raises Capacity_Error (as no expansion of capacity is possible for a
-- bounded form).
function Default_Modulus (Capacity : Count_Type) return Hash_Type;
-- Returns a modulus value (hash table size) which is optimal for the
-- specified capacity (which corresponds to the maximum number of items).
function Length (Container : Set) return Count_Type;
-- Returns the number of items in the set
function Is_Empty (Container : Set) return Boolean;
-- Equivalent to Length (Container) = 0
procedure Clear (Container : in out Set);
-- Removes all of the items from the set
function Element (Position : Cursor) return Element_Type;
-- Returns the element of the node designated by the cursor
procedure Replace_Element
(Container : in out Set;
Position : Cursor;
New_Item : Element_Type);
-- If New_Item is equivalent (as determined by calling Equivalent_Elements)
-- to the element of the node designated by Position, then New_Element is
-- assigned to that element. Otherwise, it calls Hash to determine the
-- bucket for New_Item. If the bucket is not empty, then it calls
-- Equivalent_Elements for each node in that bucket to determine whether
-- New_Item is equivalent to an element in that bucket. If
-- Equivalent_Elements returns True then Program_Error is raised (because
-- an element may appear only once in the set); otherwise, New_Item is
-- assigned to the node designated by Position, and the node is moved to
-- its new bucket.
procedure Query_Element
(Position : Cursor;
Process : not null access procedure (Element : Element_Type));
-- Calls Process with the element (having only a constant view) of the node
-- designed by the cursor.
procedure Assign (Target : in out Set; Source : Set);
-- If Target denotes the same object as Source, then the operation has no
-- effect. If the Target capacity is less then the Source length, then
-- Assign raises Capacity_Error. Otherwise, Assign clears Target and then
-- copies the (active) elements from Source to Target.
function Copy
(Source : Set;
Capacity : Count_Type := 0;
Modulus : Hash_Type := 0) return Set;
-- Constructs a new set object whose elements correspond to Source. If the
-- Capacity parameter is 0, then the capacity of the result is the same as
-- the length of Source. If the Capacity parameter is equal or greater than
-- the length of Source, then the capacity of the result is the specified
-- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter
-- is 0, then the modulus of the result is the value returned by a call to
-- Default_Modulus with the capacity parameter determined as above;
-- otherwise the modulus of the result is the specified value.
procedure Move (Target : in out Set; Source : in out Set);
-- Clears Target (if it's not empty), and then moves (not copies) the
-- buckets array and nodes from Source to Target.
procedure Insert
(Container : in out Set;
New_Item : Element_Type;
Position : out Cursor;
Inserted : out Boolean);
-- Conditionally inserts New_Item into the set. If New_Item is already in
-- the set, then Inserted returns False and Position designates the node
-- containing the existing element (which is not modified). If New_Item is
-- not already in the set, then Inserted returns True and Position
-- designates the newly-inserted node containing New_Item. The search for
-- an existing element works as follows. Hash is called to determine
-- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements
-- is called to compare New_Item to the element of each node in that
-- bucket. If the bucket is empty, or there were no equivalent elements in
-- the bucket, the search "fails" and the New_Item is inserted in the set
-- (and Inserted returns True); otherwise, the search "succeeds" (and
-- Inserted returns False).
procedure Insert (Container : in out Set; New_Item : Element_Type);
-- Attempts to insert New_Item into the set, performing the usual insertion
-- search (which involves calling both Hash and Equivalent_Elements); if
-- the search succeeds (New_Item is equivalent to an element already in the
-- set, and so was not inserted), then this operation raises
-- Constraint_Error. (This version of Insert is similar to Replace, but
-- having the opposite exception behavior. It is intended for use when you
-- want to assert that the item is not already in the set.)
procedure Include (Container : in out Set; New_Item : Element_Type);
-- Attempts to insert New_Item into the set. If an element equivalent to
-- New_Item is already in the set (the insertion search succeeded, and
-- hence New_Item was not inserted), then the value of New_Item is assigned
-- to the existing element. (This insertion operation only raises an
-- exception if cursor tampering occurs. It is intended for use when you
-- want to insert the item in the set, and you don't care whether an
-- equivalent element is already present.)
procedure Replace (Container : in out Set; New_Item : Element_Type);
-- Searches for New_Item in the set; if the search fails (because an
-- equivalent element was not in the set), then it raises
-- Constraint_Error. Otherwise, the existing element is assigned the value
-- New_Item. (This is similar to Insert, but with the opposite exception
-- behavior. It is intended for use when you want to assert that the item
-- is already in the set.)
procedure Exclude (Container : in out Set; Item : Element_Type);
-- Searches for Item in the set, and if found, removes its node from the
-- set and then deallocates it. The search works as follows. The operation
-- calls Hash to determine the item's bucket; if the bucket is not empty,
-- it calls Equivalent_Elements to compare Item to the element of each node
-- in the bucket. (This is the deletion analog of Include. It is intended
-- for use when you want to remove the item from the set, but don't care
-- whether the item is already in the set.)
procedure Delete (Container : in out Set; Item : Element_Type);
-- Searches for Item in the set (which involves calling both Hash and
-- Equivalent_Elements). If the search fails, then the operation raises
-- Constraint_Error. Otherwise it removes the node from the set and then
-- deallocates it. (This is the deletion analog of non-conditional
-- Insert. It is intended for use when you want to assert that the item is
-- already in the set.)
procedure Delete (Container : in out Set; Position : in out Cursor);
-- Removes the node designated by Position from the set, and then
-- deallocates the node. The operation calls Hash to determine the bucket,
-- and then compares Position to each node in the bucket until there's a
-- match (it does not call Equivalent_Elements).
procedure Union (Target : in out Set; Source : Set);
-- Iterates over the Source set, and conditionally inserts each element
-- into Target.
function Union (Left, Right : Set) return Set;
-- The operation first copies the Left set to the result, and then iterates
-- over the Right set to conditionally insert each element into the result.
function "or" (Left, Right : Set) return Set renames Union;
procedure Intersection (Target : in out Set; Source : Set);
-- Iterates over the Target set (calling First and Next), calling Find to
-- determine whether the element is in Source. If an equivalent element is
-- not found in Source, the element is deleted from Target.
function Intersection (Left, Right : Set) return Set;
-- Iterates over the Left set, calling Find to determine whether the
-- element is in Right. If an equivalent element is found, it is inserted
-- into the result set.
function "and" (Left, Right : Set) return Set renames Intersection;
procedure Difference (Target : in out Set; Source : Set);
-- Iterates over the Source (calling First and Next), calling Find to
-- determine whether the element is in Target. If an equivalent element is
-- found, it is deleted from Target.
function Difference (Left, Right : Set) return Set;
-- Iterates over the Left set, calling Find to determine whether the
-- element is in the Right set. If an equivalent element is not found, the
-- element is inserted into the result set.
function "-" (Left, Right : Set) return Set renames Difference;
procedure Symmetric_Difference (Target : in out Set; Source : Set);
-- The operation iterates over the Source set, searching for the element
-- in Target (calling Hash and Equivalent_Elements). If an equivalent
-- elementis found, it is removed from Target; otherwise it is inserted
-- into Target.
function Symmetric_Difference (Left, Right : Set) return Set;
-- The operation first iterates over the Left set. It calls Find to
-- determine whether the element is in the Right set. If no equivalent
-- element is found, the element from Left is inserted into the result. The
-- operation then iterates over the Right set, to determine whether the
-- element is in the Left set. If no equivalent element is found, the Right
-- element is inserted into the result.
function "xor" (Left, Right : Set) return Set
renames Symmetric_Difference;
function Overlap (Left, Right : Set) return Boolean;
-- Iterates over the Left set (calling First and Next), calling Find to
-- determine whether the element is in the Right set. If an equivalent
-- element is found, the operation immediately returns True. The operation
-- returns False if the iteration over Left terminates without finding any
-- equivalent element in Right.
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
-- Iterates over Subset (calling First and Next), calling Find to determine
-- whether the element is in Of_Set. If no equivalent element is found in
-- Of_Set, the operation immediately returns False. The operation returns
-- True if the iteration over Subset terminates without finding an element
-- not in Of_Set (that is, every element in Subset is equivalent to an
-- element in Of_Set).
function First (Container : Set) return Cursor;
-- Returns a cursor that designates the first non-empty bucket, by
-- searching from the beginning of the buckets array.
function Next (Position : Cursor) return Cursor;
-- Returns a cursor that designates the node that follows the current one
-- designated by Position. If Position designates the last node in its
-- bucket, the operation calls Hash to compute the index of this bucket,
-- and searches the buckets array for the first non-empty bucket, starting
-- from that index; otherwise, it simply follows the link to the next node
-- in the same bucket.
procedure Next (Position : in out Cursor);
-- Equivalent to Position := Next (Position)
function Find
(Container : Set;
Item : Element_Type) return Cursor;
-- Searches for Item in the set. Find calls Hash to determine the item's
-- bucket; if the bucket is not empty, it calls Equivalent_Elements to
-- compare Item to each element in the bucket. If the search succeeds, Find
-- returns a cursor designating the node containing the equivalent element;
-- otherwise, it returns No_Element.
function Contains (Container : Set; Item : Element_Type) return Boolean;
-- Equivalent to Find (Container, Item) /= No_Element
function Has_Element (Position : Cursor) return Boolean;
-- Equivalent to Position /= No_Element
function Equivalent_Elements (Left, Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Elements with the elements of
-- the nodes designated by cursors Left and Right.
function Equivalent_Elements
(Left : Cursor;
Right : Element_Type) return Boolean;
-- Returns the result of calling Equivalent_Elements with element of the
-- node designated by Left and element Right.
function Equivalent_Elements
(Left : Element_Type;
Right : Cursor) return Boolean;
-- Returns the result of calling Equivalent_Elements with element Left and
-- the element of the node designated by Right.
procedure Iterate
(Container : Set;
Process : not null access procedure (Position : Cursor));
-- Calls Process for each node in the set
generic
type Key_Type (<>) is private;
with function Key (Element : Element_Type) return Key_Type;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
package Generic_Keys is
function Key (Position : Cursor) return Key_Type;
-- Applies generic formal operation Key to the element of the node
-- designated by Position.
function Element (Container : Set; Key : Key_Type) return Element_Type;
-- Searches (as per the key-based Find) for the node containing Key, and
-- returns the associated element.
procedure Replace
(Container : in out Set;
Key : Key_Type;
New_Item : Element_Type);
-- Searches (as per the key-based Find) for the node containing Key, and
-- then replaces the element of that node (as per the element-based
-- Replace_Element).
procedure Exclude (Container : in out Set; Key : Key_Type);
-- Searches for Key in the set, and if found, removes its node from the
-- set and then deallocates it. The search works by first calling Hash
-- (on Key) to determine the bucket; if the bucket is not empty, it
-- calls Equivalent_Keys to compare parameter Key to the value of
-- generic formal operation Key applied to element of each node in the
-- bucket.
procedure Delete (Container : in out Set; Key : Key_Type);
-- Deletes the node containing Key as per Exclude, with the difference
-- that Constraint_Error is raised if Key is not found.
function Find (Container : Set; Key : Key_Type) return Cursor;
-- Searches for the node containing Key, and returns a cursor
-- designating the node. The search works by first calling Hash (on Key)
-- to determine the bucket. If the bucket is not empty, the search
-- compares Key to the element of each node in the bucket, and returns
-- the matching node. The comparison itself works by applying the
-- generic formal Key operation to the element of the node, and then
-- calling generic formal operation Equivalent_Keys.
function Contains (Container : Set; Key : Key_Type) return Boolean;
-- Equivalent to Find (Container, Key) /= No_Element
procedure Update_Element_Preserving_Key
(Container : in out Set;
Position : Cursor;
Process : not null access
procedure (Element : in out Element_Type));
-- Calls Process with the element of the node designated by Position,
-- but with the restriction that the key-value of the element is not
-- modified. The operation first makes a copy of the value returned by
-- applying generic formal operation Key on the element of the node, and
-- then calls Process with the element. The operation verifies that the
-- key-part has not been modified by calling generic formal operation
-- Equivalent_Keys to compare the saved key-value to the value returned
-- by applying generic formal operation Key to the post-Process value of
-- element. If the key values compare equal then the operation
-- completes. Otherwise, the node is removed from the map and
-- Program_Error is raised.
end Generic_Keys;
private
pragma Inline (Next);
type Node_Type is record
Element : Element_Type;
Next : Count_Type;
end record;
package HT_Types is
new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type);
type Set (Capacity : Count_Type; Modulus : Hash_Type) is
new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record;
use HT_Types;
use Ada.Streams;
type Set_Access is access all Set;
for Set_Access'Storage_Size use 0;
type Cursor is record
Container : Set_Access;
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 := (Container => null, 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 :=
(Hash_Table_Type with Capacity => 0, Modulus => 0);
end Ada.Containers.Bounded_Hashed_Sets;

322
gcc/ada/a-chtgbk.adb Normal file
View File

@ -0,0 +1,322 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
--------------------------
-- Delete_Key_Sans_Free --
--------------------------
procedure Delete_Key_Sans_Free
(HT : in out Hash_Table_Type'Class;
Key : Key_Type;
X : out Count_Type)
is
Indx : Hash_Type;
Prev : Count_Type;
begin
if HT.Length = 0 then
X := 0;
return;
end if;
Indx := Index (HT, Key);
X := HT.Buckets (Indx);
if X = 0 then
return;
end if;
if Equivalent_Keys (Key, HT.Nodes (X)) then
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
HT.Buckets (Indx) := Next (HT.Nodes (X));
HT.Length := HT.Length - 1;
return;
end if;
loop
Prev := X;
X := Next (HT.Nodes (Prev));
if X = 0 then
return;
end if;
if Equivalent_Keys (Key, HT.Nodes (X)) then
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X)));
HT.Length := HT.Length - 1;
return;
end if;
end loop;
end Delete_Key_Sans_Free;
----------
-- Find --
----------
function Find
(HT : Hash_Table_Type'Class;
Key : Key_Type) return Count_Type
is
Indx : Hash_Type;
Node : Count_Type;
begin
if HT.Length = 0 then
return 0;
end if;
Indx := Index (HT, Key);
Node := HT.Buckets (Indx);
while Node /= 0 loop
if Equivalent_Keys (Key, HT.Nodes (Node)) then
return Node;
end if;
Node := Next (HT.Nodes (Node));
end loop;
return 0;
end Find;
--------------------------------
-- Generic_Conditional_Insert --
--------------------------------
procedure Generic_Conditional_Insert
(HT : in out Hash_Table_Type'Class;
Key : Key_Type;
Node : out Count_Type;
Inserted : out Boolean)
is
Indx : constant Hash_Type := Index (HT, Key);
B : Count_Type renames HT.Buckets (Indx);
begin
if B = 0 then
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if HT.Length = HT.Capacity then
raise Capacity_Error with "no more capacity for insertion";
end if;
Node := New_Node;
Set_Next (HT.Nodes (Node), Next => 0);
Inserted := True;
B := Node;
HT.Length := HT.Length + 1;
return;
end if;
Node := B;
loop
if Equivalent_Keys (Key, HT.Nodes (Node)) then
Inserted := False;
return;
end if;
Node := Next (HT.Nodes (Node));
exit when Node = 0;
end loop;
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
if HT.Length = HT.Capacity then
raise Capacity_Error with "no more capacity for insertion";
end if;
Node := New_Node;
Set_Next (HT.Nodes (Node), Next => B);
Inserted := True;
B := Node;
HT.Length := HT.Length + 1;
end Generic_Conditional_Insert;
-----------
-- Index --
-----------
function Index
(HT : Hash_Table_Type'Class;
Key : Key_Type) return Hash_Type is
begin
return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
end Index;
-----------------------------
-- Generic_Replace_Element --
-----------------------------
procedure Generic_Replace_Element
(HT : in out Hash_Table_Type'Class;
Node : Count_Type;
Key : Key_Type)
is
pragma Assert (HT.Length > 0);
pragma Assert (Node /= 0);
BB : Buckets_Type renames HT.Buckets;
NN : Nodes_Type renames HT.Nodes;
Old_Hash : constant Hash_Type := Hash (NN (Node));
Old_Indx : constant Hash_Type := BB'First + Old_Hash mod BB'Length;
New_Hash : constant Hash_Type := Hash (Key);
New_Indx : constant Hash_Type := BB'First + New_Hash mod BB'Length;
New_Bucket : Count_Type renames BB (New_Indx);
N, M : Count_Type;
begin
-- Replace_Element is allowed to change a node's key to Key
-- (generic formal operation Assign provides the mechanism), but
-- only if Key is not already in the hash table. (In a unique-key
-- hash table as this one, a key is mapped to exactly one node.)
if Equivalent_Keys (Key, NN (Node)) then
pragma Assert (New_Hash = Old_Hash);
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (container is locked)";
end if;
-- The new Key value is mapped to this same Node, so Node
-- stays in the same bucket.
Assign (NN (Node), Key);
pragma Assert (Hash (NN (Node)) = New_Hash);
pragma Assert (Equivalent_Keys (Key, NN (Node)));
return;
end if;
-- Key is not equivalent to Node, so we now have to determine if it's
-- equivalent to some other node in the hash table. This is the case
-- irrespective of whether Key is in the same or a different bucket from
-- Node.
N := New_Bucket;
while N /= 0 loop
if Equivalent_Keys (Key, NN (N)) then
pragma Assert (N /= Node);
raise Program_Error with
"attempt to replace existing element";
end if;
N := Next (NN (N));
end loop;
-- We have determined that Key is not already in the hash table, so
-- the change is tentatively allowed. We now perform the standard
-- checks to determine whether the hash table is locked (because you
-- cannot change an element while it's in use by Query_Element or
-- Update_Element), or if the container is busy (because moving a
-- node to a different bucket would interfere with iteration).
if Old_Indx = New_Indx then
-- The node is already in the bucket implied by Key. In this case
-- we merely change its value without moving it.
if HT.Lock > 0 then
raise Program_Error with
"attempt to tamper with elements (container is locked)";
end if;
Assign (NN (Node), Key);
pragma Assert (Hash (NN (Node)) = New_Hash);
pragma Assert (Equivalent_Keys (Key, NN (Node)));
return;
end if;
-- The node is a bucket different from the bucket implied by Key
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
-- Do the assignment first, before moving the node, so that if Assign
-- propagates an exception, then the hash table will not have been
-- modified (except for any possible side-effect Assign had on Node).
Assign (NN (Node), Key);
pragma Assert (Hash (NN (Node)) = New_Hash);
pragma Assert (Equivalent_Keys (Key, NN (Node)));
-- Now we can safely remove the node from its current bucket
N := BB (Old_Indx); -- get value of first node in old bucket
pragma Assert (N /= 0);
if N = Node then -- node is first node in its bucket
BB (Old_Indx) := Next (NN (Node));
else
pragma Assert (HT.Length > 1);
loop
M := Next (NN (N));
pragma Assert (M /= 0);
if M = Node then
Set_Next (NN (N), Next => Next (NN (Node)));
exit;
end if;
N := M;
end loop;
end if;
-- Now we link the node into its new bucket (corresponding to Key)
Set_Next (NN (Node), Next => New_Bucket);
New_Bucket := Node;
end Generic_Replace_Element;
end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;

106
gcc/ada/a-chtgbk.ads Normal file
View File

@ -0,0 +1,106 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-- Hash_Table_Type is used to implement hashed containers. This package
-- declares hash-table operations that depend on keys.
generic
with package HT_Types is
new Generic_Bounded_Hash_Table_Types (<>);
use HT_Types;
with function Next (Node : Node_Type) return Count_Type;
with procedure Set_Next
(Node : in out Node_Type;
Next : Count_Type);
type Key_Type (<>) is limited private;
with function Hash (Key : Key_Type) return Hash_Type;
with function Equivalent_Keys
(Key : Key_Type;
Node : Node_Type) return Boolean;
package Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
pragma Pure;
function Index
(HT : Hash_Table_Type'Class;
Key : Key_Type) return Hash_Type;
pragma Inline (Index);
-- Returns the bucket number (array index value) for the given key
procedure Delete_Key_Sans_Free
(HT : in out Hash_Table_Type'Class;
Key : Key_Type;
X : out Count_Type);
-- Removes the node (if any) with the given key from the hash table,
-- without deallocating it. Program_Error is raised if the hash
-- table is busy.
function Find
(HT : Hash_Table_Type'Class;
Key : Key_Type) return Count_Type;
-- Returns the node (if any) corresponding to the given key
generic
with function New_Node return Count_Type;
procedure Generic_Conditional_Insert
(HT : in out Hash_Table_Type'Class;
Key : Key_Type;
Node : out Count_Type;
Inserted : out Boolean);
-- Attempts to insert a new node with the given key into the hash table.
-- If a node with that key already exists in the table, then that node
-- is returned and Inserted returns False. Otherwise New_Node is called
-- to allocate a new node, and Inserted returns True. Program_Error is
-- raised if the hash table is busy.
generic
with function Hash (Node : Node_Type) return Hash_Type;
with procedure Assign (Node : in out Node_Type; Key : Key_Type);
procedure Generic_Replace_Element
(HT : in out Hash_Table_Type'Class;
Node : Count_Type;
Key : Key_Type);
-- Assigns Key to Node, possibly changing its equivalence class. If Node
-- is in the same equivalence class as Key (that is, it's already in the
-- bucket implied by Key), then if the hash table is locked then
-- Program_Error is raised; otherwise Assign is called to assign Key to
-- Node. If Node is in a different bucket from Key, then Program_Error is
-- raised if the hash table is busy. Otherwise it Assigns Key to Node and
-- moves the Node from its current bucket to the bucket implied by Key.
-- Note that it is never proper to assign to Node a key value already
-- in the map, and so if Key is equivalent to some other node then
-- Program_Error is raised.
end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;

473
gcc/ada/a-chtgbo.adb Normal file
View File

@ -0,0 +1,473 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
with System; use type System.Address;
package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
-----------
-- Clear --
-----------
procedure Clear (HT : in out Hash_Table_Type'Class) is
begin
if HT.Busy > 0 then
raise Program_Error with
"attempt to tamper with cursors (container is busy)";
end if;
HT.Length := 0;
-- HT.Busy := 0;
-- HT.Lock := 0;
HT.Free := -1;
HT.Buckets := (others => 0); -- optimize this somehow ???
end Clear;
---------------------------
-- Delete_Node_Sans_Free --
---------------------------
procedure Delete_Node_Sans_Free
(HT : in out Hash_Table_Type'Class;
X : Count_Type)
is
pragma Assert (X /= 0);
Indx : Hash_Type;
Prev : Count_Type;
Curr : Count_Type;
begin
if HT.Length = 0 then
raise Program_Error with
"attempt to delete node from empty hashed container";
end if;
Indx := Index (HT, HT.Nodes (X));
Prev := HT.Buckets (Indx);
if Prev = 0 then
raise Program_Error with
"attempt to delete node from empty hash bucket";
end if;
if Prev = X then
HT.Buckets (Indx) := Next (HT, Prev);
HT.Length := HT.Length - 1;
return;
end if;
if HT.Length = 1 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
loop
Curr := Next (HT, Prev);
if Curr = 0 then
raise Program_Error with
"attempt to delete node not in its proper hash bucket";
end if;
if Curr = X then
Set_Next (HT.Nodes (Prev), Next => Next (HT, Curr));
HT.Length := HT.Length - 1;
return;
end if;
Prev := Curr;
end loop;
end Delete_Node_Sans_Free;
-----------
-- First --
-----------
function First (HT : Hash_Table_Type'Class) return Count_Type is
Indx : Hash_Type;
begin
if HT.Length = 0 then
return 0;
end if;
Indx := HT.Buckets'First;
loop
if HT.Buckets (Indx) /= 0 then
return HT.Buckets (Indx);
end if;
Indx := Indx + 1;
end loop;
end First;
----------
-- Free --
----------
procedure Free
(HT : in out Hash_Table_Type'Class;
X : Count_Type)
is
pragma Assert (X > 0);
pragma Assert (X <= HT.Capacity);
N : Nodes_Type renames HT.Nodes;
-- pragma Assert (N (X).Prev >= 0); -- node is active
-- Find a way to mark a node as active vs. inactive; we could
-- use a special value in Color_Type for this. ???
begin
-- The hash table actually contains two data structures: a list for
-- the "active" nodes that contain elements that have been inserted
-- onto the container, and another for the "inactive" nodes of the free
-- store.
--
-- We desire that merely declaring an object should have only minimal
-- cost; specially, we want to avoid having to initialize the free
-- store (to fill in the links), especially if the capacity is large.
--
-- The head of the free list is indicated by Container.Free. If its
-- value is non-negative, then the free store has been initialized
-- in the "normal" way: Container.Free points to the head of the list
-- of free (inactive) nodes, and the value 0 means the free list is
-- empty. Each node on the free list has been initialized to point
-- to the next free node (via its Parent component), and the value 0
-- means that this is the last free node.
--
-- If Container.Free is negative, then the links on the free store
-- have not been initialized. In this case the link values are
-- implied: the free store comprises the components of the node array
-- started with the absolute value of Container.Free, and continuing
-- until the end of the array (Nodes'Last).
--
-- ???
-- It might be possible to perform an optimization here. Suppose that
-- the free store can be represented as having two parts: one
-- comprising the non-contiguous inactive nodes linked together
-- in the normal way, and the other comprising the contiguous
-- inactive nodes (that are not linked together, at the end of the
-- nodes array). This would allow us to never have to initialize
-- the free store, except in a lazy way as nodes become inactive.
-- When an element is deleted from the list container, its node
-- becomes inactive, and so we set its Next component to value of
-- the node's index (in the nodes array), to indicate that it is
-- now inactive. This provides a useful way to detect a dangling
-- cursor reference. ???
Set_Next (N (X), Next => X); -- Node is deallocated (not on active list)
if HT.Free >= 0 then
-- The free store has previously been initialized. All we need to
-- do here is link the newly-free'd node onto the free list.
Set_Next (N (X), HT.Free);
HT.Free := X;
elsif X + 1 = abs HT.Free then
-- The free store has not been initialized, and the node becoming
-- inactive immediately precedes the start of the free store. All
-- we need to do is move the start of the free store back by one.
HT.Free := HT.Free + 1;
else
-- The free store has not been initialized, and the node becoming
-- inactive does not immediately precede the free store. Here we
-- first initialize the free store (meaning the links are given
-- values in the traditional way), and then link the newly-free'd
-- node onto the head of the free store.
-- ???
-- See the comments above for an optimization opportunity. If
-- the next link for a node on the free store is negative, then
-- this means the remaining nodes on the free store are
-- physically contiguous, starting as the absolute value of
-- that index value.
HT.Free := abs HT.Free;
if HT.Free > HT.Capacity then
HT.Free := 0;
else
for I in HT.Free .. HT.Capacity - 1 loop
Set_Next (Node => N (I), Next => I + 1);
end loop;
Set_Next (Node => N (HT.Capacity), Next => 0);
end if;
Set_Next (Node => N (X), Next => HT.Free);
HT.Free := X;
end if;
end Free;
----------------------
-- Generic_Allocate --
----------------------
procedure Generic_Allocate
(HT : in out Hash_Table_Type'Class;
Node : out Count_Type)
is
N : Nodes_Type renames HT.Nodes;
begin
if HT.Free >= 0 then
Node := HT.Free;
-- We always perform the assignment first, before we
-- change container state, in order to defend against
-- exceptions duration assignment.
Set_Element (N (Node));
HT.Free := Next (N (Node));
else
-- A negative free store value means that the links of the nodes
-- in the free store have not been initialized. In this case, the
-- nodes are physically contiguous in the array, starting at the
-- index that is the absolute value of the Container.Free, and
-- continuing until the end of the array (Nodes'Last).
Node := abs HT.Free;
-- As above, we perform this assignment first, before modifying
-- any container state.
Set_Element (N (Node));
HT.Free := HT.Free - 1;
end if;
end Generic_Allocate;
-------------------
-- Generic_Equal --
-------------------
function Generic_Equal
(L, R : Hash_Table_Type'Class) return Boolean
is
L_Index : Hash_Type;
L_Node : Count_Type;
N : Count_Type;
begin
if L'Address = R'Address then
return True;
end if;
if L.Length /= R.Length then
return False;
end if;
if L.Length = 0 then
return True;
end if;
-- Find the first node of hash table L
L_Index := 0;
loop
L_Node := L.Buckets (L_Index);
exit when L_Node /= 0;
L_Index := L_Index + 1;
end loop;
-- For each node of hash table L, search for an equivalent node in hash
-- table R.
N := L.Length;
loop
if not Find (HT => R, Key => L.Nodes (L_Node)) then
return False;
end if;
N := N - 1;
L_Node := Next (L, L_Node);
if L_Node = 0 then
-- We have exhausted the nodes in this bucket
if N = 0 then
return True;
end if;
-- Find the next bucket
loop
L_Index := L_Index + 1;
L_Node := L.Buckets (L_Index);
exit when L_Node /= 0;
end loop;
end if;
end loop;
end Generic_Equal;
-----------------------
-- Generic_Iteration --
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type'Class) is
Node : Count_Type;
begin
if HT.Length = 0 then
return;
end if;
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= 0 loop
Process (Node);
Node := Next (HT, Node);
end loop;
end loop;
end Generic_Iteration;
------------------
-- Generic_Read --
------------------
procedure Generic_Read
(Stream : not null access Root_Stream_Type'Class;
HT : out Hash_Table_Type'Class)
is
N : Count_Type'Base;
begin
Clear (HT);
Count_Type'Base'Read (Stream, N);
if N < 0 then
raise Program_Error with "stream appears to be corrupt";
end if;
if N = 0 then
return;
end if;
if N > HT.Capacity then
raise Capacity_Error with "too many elements in stream";
end if;
for J in 1 .. N loop
declare
Node : constant Count_Type := New_Node (Stream);
Indx : constant Hash_Type := Index (HT, HT.Nodes (Node));
B : Count_Type renames HT.Buckets (Indx);
begin
Set_Next (HT.Nodes (Node), Next => B);
B := Node;
end;
HT.Length := HT.Length + 1;
end loop;
end Generic_Read;
-------------------
-- Generic_Write --
-------------------
procedure Generic_Write
(Stream : not null access Root_Stream_Type'Class;
HT : Hash_Table_Type'Class)
is
procedure Write (Node : Count_Type);
pragma Inline (Write);
procedure Write is new Generic_Iteration (Write);
-----------
-- Write --
-----------
procedure Write (Node : Count_Type) is
begin
Write (Stream, HT.Nodes (Node));
end Write;
begin
Count_Type'Base'Write (Stream, HT.Length);
Write (HT);
end Generic_Write;
-----------
-- Index --
-----------
function Index
(Buckets : Buckets_Type;
Node : Node_Type) return Hash_Type is
begin
return Buckets'First + Hash_Node (Node) mod Buckets'Length;
end Index;
function Index
(HT : Hash_Table_Type'Class;
Node : Node_Type) return Hash_Type is
begin
return Index (HT.Buckets, Node);
end Index;
----------
-- Next --
----------
function Next
(HT : Hash_Table_Type'Class;
Node : Count_Type) return Count_Type
is
Result : Count_Type := Next (HT.Nodes (Node));
begin
if Result /= 0 then -- another node in same bucket
return Result;
end if;
-- This was the last node in the bucket, so move to the next
-- bucket, and start searching for next node from there.
for Indx in Index (HT, HT.Nodes (Node)) + 1 .. HT.Buckets'Last loop
Result := HT.Buckets (Indx);
if Result /= 0 then -- bucket is not empty
return Result;
end if;
end loop;
return 0;
end Next;
end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;

140
gcc/ada/a-chtgbo.ads Normal file
View File

@ -0,0 +1,140 @@
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS --
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-- Hash_Table_Type is used to implement hashed containers. This package
-- declares hash-table operations that do not depend on keys.
with Ada.Streams;
generic
with package HT_Types is
new Generic_Bounded_Hash_Table_Types (<>);
use HT_Types;
with function Hash_Node (Node : Node_Type) return Hash_Type;
with function Next (Node : Node_Type) return Count_Type;
with procedure Set_Next
(Node : in out Node_Type;
Next : Count_Type);
package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
pragma Pure;
function Index
(Buckets : Buckets_Type;
Node : Node_Type) return Hash_Type;
pragma Inline (Index);
-- Uses the hash value of Node to compute its Buckets array index
function Index
(HT : Hash_Table_Type'Class;
Node : Node_Type) return Hash_Type;
pragma Inline (Index);
-- Uses the hash value of Node to compute its Hash_Table buckets array
-- index.
generic
with function Find
(HT : Hash_Table_Type'Class;
Key : Node_Type) return Boolean;
function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean;
-- Used to implement hashed container equality. For each node in hash table
-- L, it calls Find to search for an equivalent item in hash table R. If
-- Find returns False for any node then Generic_Equal terminates
-- immediately and returns False. Otherwise if Find returns True for every
-- node then Generic_Equal returns True.
procedure Clear (HT : in out Hash_Table_Type'Class);
-- Deallocates each node in hash table HT. (Note that it only deallocates
-- the nodes, not the buckets array.) Program_Error is raised if the hash
-- table is busy.
procedure Delete_Node_Sans_Free
(HT : in out Hash_Table_Type'Class;
X : Count_Type);
-- Removes node X from the hash table without deallocating the node
generic
with procedure Set_Element (Node : in out Node_Type);
procedure Generic_Allocate
(HT : in out Hash_Table_Type'Class;
Node : out Count_Type);
-- Claim a node from the free store. Generic_Allocate first
-- calls Set_Element on the potential node, and then returns
-- the node's index as the value of the Node parameter.
procedure Free
(HT : in out Hash_Table_Type'Class;
X : Count_Type);
-- Return a node back to the free store, from where it had
-- been previously claimed via Generic_Allocate.
function First (HT : Hash_Table_Type'Class) return Count_Type;
-- Returns the head of the list in the first (lowest-index) non-empty
-- bucket.
function Next
(HT : Hash_Table_Type'Class;
Node : Count_Type) return Count_Type;
-- Returns the node that immediately follows Node. This corresponds to
-- either the next node in the same bucket, or (if Node is the last node in
-- its bucket) the head of the list in the first non-empty bucket that
-- follows.
generic
with procedure Process (Node : Count_Type);
procedure Generic_Iteration (HT : Hash_Table_Type'Class);
-- Calls Process for each node in hash table HT
generic
use Ada.Streams;
with procedure Write
(Stream : not null access Root_Stream_Type'Class;
Node : Node_Type);
procedure Generic_Write
(Stream : not null access Root_Stream_Type'Class;
HT : Hash_Table_Type'Class);
-- Used to implement the streaming attribute for hashed containers. It
-- calls Write for each node to write its value into Stream.
generic
use Ada.Streams;
with function New_Node (Stream : not null access Root_Stream_Type'Class)
return Count_Type;
procedure Generic_Read
(Stream : not null access Root_Stream_Type'Class;
HT : out Hash_Table_Type'Class);
-- Used to implement the streaming attribute for hashed containers. It
-- first clears hash table HT, then populates the hash table by calling
-- New_Node for each item in Stream.
end Ada.Containers.Hash_Tables.Generic_Bounded_Operations;

21
gcc/ada/a-cohata.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2010, 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- --
@ -52,4 +52,23 @@ package Ada.Containers.Hash_Tables is
end record;
end Generic_Hash_Table_Types;
generic
type Node_Type is private;
package Generic_Bounded_Hash_Table_Types is
type Nodes_Type is array (Count_Type range <>) of Node_Type;
type Buckets_Type is array (Hash_Type range <>) of Count_Type;
type Hash_Table_Type
(Capacity : Count_Type;
Modulus : Hash_Type) is
tagged record
Length : Count_Type := 0;
Busy : Natural := 0;
Lock : Natural := 0;
Free : Count_Type'Base := -1;
Nodes : Nodes_Type (1 .. Capacity);
Buckets : Buckets_Type (1 .. Modulus) := (others => 0);
end record;
end Generic_Bounded_Hash_Table_Types;
end Ada.Containers.Hash_Tables;

19
gcc/ada/exp_ch3.adb
View File

@ -4508,25 +4508,6 @@ package body Exp_Ch3 is
return;
end if;
-- Deal with predicate check before we start to do major rewriting.
-- it is OK to initialize and then check the initialized value, since
-- the object goes out of scope if we get a predicate failure.
-- We need a predicate check if the type has predicates, and if either
-- there is an initializing expression, or for default initialization
-- when we have at least one case of an explicit default initial value.
if not Suppress_Assignment_Checks (N)
and then Present (Predicate_Function (Typ))
and then
(Present (Expr)
or else
Is_Partially_Initialized_Type (Typ, Include_Null => False))
then
Insert_After (N,
Make_Predicate_Check (Typ, New_Occurrence_Of (Def_Id, Loc)));
end if;
-- Force construction of dispatch tables of library level tagged types
if Tagged_Type_Expansion

38
gcc/ada/exp_dist.adb
View File

@ -1011,7 +1011,7 @@ package body Exp_Dist is
-- Subprogram id 0 is reserved for calls received from
-- remote access-to-subprogram dereferences.
RCI_Instantiation : Node_Id;
RCI_Instantiation : Node_Id;
procedure Visit_Subprogram (Decl : Node_Id);
-- Generate calling stub for one remote subprogram
@ -1024,7 +1024,8 @@ package body Exp_Dist is
Loc : constant Source_Ptr := Sloc (Decl);
Spec : constant Node_Id := Specification (Decl);
Subp_Stubs : Node_Id;
Subp_Str : String_Id;
Subp_Str : String_Id;
pragma Warnings (Off, Subp_Str);
begin
@ -1032,13 +1033,13 @@ package body Exp_Dist is
(Defining_Unit_Name (Spec), Current_Subprogram_Number, Subp_Str);
Subp_Stubs :=
Build_Subprogram_Calling_Stubs (
Vis_Decl => Decl,
Subp_Id =>
Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
Asynchronous =>
Nkind (Spec) = N_Procedure_Specification
and then Is_Asynchronous (Defining_Unit_Name (Spec)));
Build_Subprogram_Calling_Stubs
(Vis_Decl => Decl,
Subp_Id =>
Build_Subprogram_Id (Loc, Defining_Unit_Name (Spec)),
Asynchronous =>
Nkind (Spec) = N_Procedure_Specification
and then Is_Asynchronous (Defining_Unit_Name (Spec)));
Append_To (List_Containing (Decl), Subp_Stubs);
Analyze (Subp_Stubs);
@ -1067,7 +1068,7 @@ package body Exp_Dist is
-- For each subprogram declaration visible in the spec, we do build a
-- body. We also increment a counter to assign a different Subprogram_Id
-- to each subprograms. The receiving stubs processing uses the same
-- to each subprogram. The receiving stubs processing uses the same
-- mechanism and will thus assign the same Id and do the correct
-- dispatching.
@ -6830,12 +6831,12 @@ package body Exp_Dist is
Subp_Val : String_Id;
Subp_Dist_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
(Related_Id => Chars (Subp_Def),
Suffix => 'D',
Suffix_Index => -1));
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name
(Related_Id => Chars (Subp_Def),
Suffix => 'D',
Suffix_Index => -1));
Current_Stubs : Node_Id;
Proxy_Obj_Addr : Entity_Id;
@ -6846,9 +6847,8 @@ package body Exp_Dist is
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Decl,
Asynchronous =>
Nkind (Spec) = N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Asynchronous => Nkind (Spec) = N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);

142
gcc/ada/gnat_rm.texi
View File

@ -1762,124 +1762,70 @@ gnat_ugn, @value{EDITION} User's Guide}.
Syntax:
@smallexample @c ada
pragma Eliminate (
[Unit_Name =>] IDENTIFIER |
SELECTED_COMPONENT);
pragma Eliminate (UNIT_NAME, ENTITY, Source_Location => SOURCE_TRACE)
pragma Eliminate (
[Unit_Name =>] IDENTIFIER |
SELECTED_COMPONENT,
[Entity =>] IDENTIFIER |
SELECTED_COMPONENT |
STRING_LITERAL
[,OVERLOADING_RESOLUTION]);
UNIT_NAME ::= IDENTIFIER |
SELECTED_COMPONENT,
OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
SOURCE_LOCATION
ENTITY ::= IDENTIFIER |
SELECTED_COMPONENT,
PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
FUNCTION_PROFILE
SOURCE_TRACE ::= SOURCE_REFERENCE |
SOURCE_REFERENCE LBRACKET SOURCE_TRACE RBRACKET
PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
LBRACKET ::= [
RBRACKET ::= ]
FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
Result_Type => result_SUBTYPE_NAME]
SOURCE_REFERENCE ::= FILE_NAME : LINE_NUMBER
PARAMETER_TYPES ::= (SUBTYPE_NAME @{, SUBTYPE_NAME@})
SUBTYPE_NAME ::= STRING_VALUE
SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
SOURCE_TRACE ::= STRING_VALUE
STRING_VALUE ::= STRING_LITERAL @{& STRING_LITERAL@}
FILE_NAME ::= STRING_LITERAL
LINE_NUMBER ::= INTEGER_LITERAL
@end smallexample
@noindent
This pragma indicates that the given entity is not used outside the
compilation unit it is defined in. The entity must be an explicitly declared
subprogram; this includes generic subprogram instances and
subprograms declared in generic package instances.
This pragma indicates that the given entity is not used in the program
to be compiled and built. The entity must be an explicitly declared
subprogram; this includes generic subprogram instances and
subprograms declared in generic package instances. @code{Unit_Name}
must be the name of the compilation unit in which the entity is declared.
If the entity to be eliminated is a library level subprogram, then
the first form of pragma @code{Eliminate} is used with only a single argument.
In this form, the @code{Unit_Name} argument specifies the name of the
library level unit to be eliminated.
In all other cases, both @code{Unit_Name} and @code{Entity} arguments
are required. If item is an entity of a library package, then the first
argument specifies the unit name, and the second argument specifies
the particular entity. If the second argument is in string form, it must
correspond to the internal manner in which GNAT stores entity names (see
compilation unit Namet in the compiler sources for details).
The remaining parameters (OVERLOADING_RESOLUTION) are optionally used
to distinguish between overloaded subprograms. If a pragma does not contain
the OVERLOADING_RESOLUTION parameter(s), it is applied to all the overloaded
subprograms denoted by the first two parameters.
Use PARAMETER_AND_RESULT_TYPE_PROFILE to specify the profile of the subprogram
to be eliminated in a manner similar to that used for the extended
@code{Import} and @code{Export} pragmas, except that the subtype names are
always given as strings. At the moment, this form of distinguishing
overloaded subprograms is implemented only partially, so we do not recommend
using it for practical subprogram elimination.
Note that in case of a parameterless procedure its profile is represented
as @code{Parameter_Types => ("")}
Alternatively, the @code{Source_Location} parameter is used to specify
which overloaded alternative is to be eliminated by pointing to the
location of the DEFINING_PROGRAM_UNIT_NAME of this subprogram in the
source text. The string literal (or concatenation of string literals)
given as SOURCE_TRACE must have the following format:
@smallexample @c ada
SOURCE_TRACE ::= SOURCE_LOCATION@{LBRACKET SOURCE_LOCATION RBRACKET@}
LBRACKET ::= [
RBRACKET ::= ]
SOURCE_LOCATION ::= FILE_NAME:LINE_NUMBER
FILE_NAME ::= STRING_LITERAL
LINE_NUMBER ::= DIGIT @{DIGIT@}
@end smallexample
SOURCE_TRACE should be the short name of the source file (with no directory
information), and LINE_NUMBER is supposed to point to the line where the
defining name of the subprogram is located.
For the subprograms that are not a part of generic instantiations, only one
SOURCE_LOCATION is used. If a subprogram is declared in a package
instantiation, SOURCE_TRACE contains two SOURCE_LOCATIONs, the first one is
the location of the (DEFINING_PROGRAM_UNIT_NAME of the) instantiation, and the
second one denotes the declaration of the corresponding subprogram in the
generic package. This approach is recursively used to create SOURCE_LOCATIONs
in case of nested instantiations.
The @code{Source_Location} argument is used to resolve overloading
in case more then one callable entity with the same name is declared
in the given compilation unit. Each file name must be the short name of the
source file (with no directory information).
If an entity is not declared in
a generic instantiation (this includes generic subprogram instances),
the source trace includes only one source
reference. If an entity is declared inside a generic instantiation,
its source trace starts from the source location in the instantiation and
ends with the source location of the declaration of the corresponding
entity in the generic
unit. This approach is recursively used in case of nested instantiations:
the leftmost element of the
source trace is the location of the outermost instantiation, the next
element is the location of the next (first nested) instantiation in the
code of the corresponding generic unit, and so on.
The effect of the pragma is to allow the compiler to eliminate
the code or data associated with the named entity. Any reference to
an eliminated entity outside the compilation unit it is defined in,
causes a compile time or link time error.
an eliminated entity outside the compilation unit where it is defined
causes a compile-time or link-time error.
The intention of pragma @code{Eliminate} is to allow a program to be compiled
in a system independent manner, with unused entities eliminated, without
the requirement of modifying the source text. Normally the required set
in a system-independent manner, with unused entities eliminated, without
needing to modify the source text. Normally the required set
of @code{Eliminate} pragmas is constructed automatically using the gnatelim
tool. Elimination of unused entities local to a compilation unit is
automatic, without requiring the use of pragma @code{Eliminate}.
Note that the reason this pragma takes string literals where names might
be expected is that a pragma @code{Eliminate} can appear in a context where the
relevant names are not visible.
Any source file change that removes, splits, or
adds lines may make the set of Eliminate pragmas invalid because their
@code{Source_Location} argument values may get out of date.
Note that any change in the source files that includes removing, splitting of
adding lines may make the set of Eliminate pragmas using SOURCE_LOCATION
parameter illegal.
It is legal to use pragma Eliminate where the referenced entity is a
dispatching operation, but it is not clear what this would mean, since
in general the call does not know which entity is actually being called.
Consequently, a pragma Eliminate for a dispatching operation is ignored.
Pragma Eliminate may be used where the referenced entity is a
dispatching operation. In this case all the subprograms to which the
given operation can dispatch are considered to be unused (are never called
as a result of a direct or a dispatching call).
@node Pragma Export_Exception
@unnumberedsec Pragma Export_Exception

4
gcc/ada/impunit.adb
View File

@ -510,7 +510,9 @@ package body Impunit is
"a-cobove", -- Ada.Containers.Bounded_Vectors
"a-cbdlli", -- Ada.Containers.Bounded_Doubly_Linked_Lists
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
"a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps
"a-cborma", -- Ada.Containers.Bounded_Ordered_Maps
"a-cbhase", -- Ada.Containers.Bounded_Hashed_Sets
"a-cbhama"); -- Ada.Containers.Bounded_Hashed_Maps
-----------------------
-- Alternative Units --

15
gcc/ada/makeusg.adb
View File

@ -196,6 +196,21 @@ begin
Write_Str (" -v Display reasons for all (re)compilations");
Write_Eol;
-- Line for -vl
Write_Str (" -vl Verbose output (low verbosity)");
Write_Eol;
-- Line for -vm
Write_Str (" -vm Verbose output (medium verbosity)");
Write_Eol;
-- Line for -vh
Write_Str (" -vh Equivalent to -v (high verbosity)");
Write_Eol;
-- Line for -vPx
Write_Str (" -vPx Specify verbosity when parsing GNAT Project Files");

184
gcc/ada/sem_ch13.adb
View File

@ -44,6 +44,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@ -77,18 +78,15 @@ package body Sem_Ch13 is
-- inherited from a derived type that is no longer appropriate for the
-- new Esize value. In this case, we reset the Alignment to unknown.
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id);
procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ,
-- then either there are pragma Invariant entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragam Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes,
-- or interfaces. This procedure builds the spec and body for the Predicate
-- function that tests these predicates, returning them in PDecl and Pbody
-- and setting Predicate_Procedure for Typ. In some error situations no
-- procedure is built, in which case PDecl/PBody are empty on return.
-- there are inherited aspects from a parent type, or ancestor subtypes.
-- This procedure builds the spec and body for the Predicate function that
-- tests these predicates. N is the freeze node for the type. The spec of
-- the function is inserted before the freeze node, and the body of the
-- funtion is inserted after the freeze node.
procedure Build_Static_Predicate
(Typ : Entity_Id;
@ -3070,18 +3068,7 @@ package body Sem_Ch13 is
-- If we have a type with predicates, build predicate function
if Is_Type (E) and then Has_Predicates (E) then
declare
FDecl : Node_Id;
FBody : Node_Id;
begin
Build_Predicate_Function (E, FDecl, FBody);
if Present (FDecl) then
Insert_After (N, FBody);
Insert_After (N, FDecl);
end if;
end;
Build_Predicate_Function (E, N);
end if;
end Analyze_Freeze_Entity;
@ -3839,14 +3826,15 @@ package body Sem_Ch13 is
-- inherited. Note that we do NOT generate Check pragmas, that's because we
-- use this function even if checks are off, e.g. for membership tests.
procedure Build_Predicate_Function
(Typ : Entity_Id;
FDecl : out Node_Id;
FBody : out Node_Id)
is
procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
Spec : Node_Id;
SId : Entity_Id;
FDecl : Node_Id;
FBody : Node_Id;
TName : constant Name_Id := Chars (Typ);
-- Name of the type, used for replacement in predicate expression
Expr : Node_Id;
-- This is the expression for the return statement in the function. It
@ -3898,11 +3886,14 @@ package body Sem_Ch13 is
-- Output info message on inheritance if required. Note we do not
-- give this information for generic actual types, since it is
-- unwelcome noise in that case in instantiations. We also
-- generally suppress the message in instantiations.
-- generally suppress the message in instantiations, and also
-- if it involves internal names.
if Opt.List_Inherited_Aspects
and then not Is_Generic_Actual_Type (Typ)
and then Instantiation_Depth (Sloc (Typ)) = 0
and then not Is_Internal_Name (Chars (T))
and then not Is_Internal_Name (Chars (Typ))
then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
@ -3924,34 +3915,102 @@ package body Sem_Ch13 is
-- Process single node for traversal to replace type references
procedure Replace_Type is new Traverse_Proc (Replace_Node);
-- Traverse an expression changing every occurrence of an entity
-- reference to type T with a reference to the object argument.
-- Traverse an expression changing every occurrence of an identifier
-- whose name is TName with a reference to the object argument.
------------------
-- Replace_Node --
------------------
function Replace_Node (N : Node_Id) return Traverse_Result is
S : Entity_Id;
P : Node_Id;
begin
-- Case of entity name referencing the type
-- Case of identifier
if Is_Entity_Name (N) and then Entity (N) = Typ then
if Nkind (N) = N_Identifier then
-- Replace with object
-- If not the type name, all done with this node
Rewrite (N,
Make_Identifier (Loc,
Chars => Object_Name));
if Chars (N) /= TName then
return Skip;
-- All done with this node
-- Otherwise do the replacement
return Skip;
else
goto Do_Replace;
end if;
-- Not an occurrence of the type entity, keep going
-- Case of selected component (which is what a qualification
-- looks like in the unanalyzed tree, which is what we have.
elsif Nkind (N) = N_Selected_Component then
-- If selector name is not our type, keeping going (we might
-- still have an occurrence of the type in the prefix).
if Nkind (Selector_Name (N)) /= N_Identifier
or else Chars (Selector_Name (N)) /= TName
then
return OK;
-- Selector name is our type, check qualification
else
-- Loop through scopes and prefixes, doing comparison
S := Current_Scope;
P := Prefix (N);
loop
-- Continue if no more scopes or scope with no name
if No (S) or else Nkind (S) not in N_Has_Chars then
return OK;
end if;
-- Do replace if prefix is an identifier matching the
-- scope that we are currently looking at.
if Nkind (P) = N_Identifier
and then Chars (P) = Chars (S)
then
goto Do_Replace;
end if;
-- Go check scope above us if prefix is itself of the
-- form of a selected component, whose selector matches
-- the scope we are currently looking at.
if Nkind (P) = N_Selected_Component
and then Nkind (Selector_Name (P)) = N_Identifier
and then Chars (Selector_Name (P)) = Chars (S)
then
S := Scope (S);
P := Prefix (P);
-- For anything else, we don't have a match, so keep on
-- going, there are still some weird cases where we may
-- still have a replacement within the prefix.
else
return OK;
end if;
end loop;
end if;
-- Continue for any other node kind
else
return OK;
end if;
<<Do_Replace>>
-- Replace with object
Rewrite (N, Make_Identifier (Loc, Chars => Object_Name));
return Skip;
end Replace_Node;
-- Start of processing for Add_Predicates
@ -3975,17 +4034,8 @@ package body Sem_Ch13 is
-- We have a match, this entry is for our subtype
-- First We need to replace any occurrences of the name of
-- the type with references to the object. We do this by
-- first doing a preanalysis, to identify all the entities,
-- then we traverse looking for the type entity, doing the
-- needed substitution. The preanalysis is done with the
-- special OK_To_Reference flag set on the type, so that if
-- we get an occurrence of this type, it will be recognized
-- as legitimate.
-- the type with references to the object.
Set_OK_To_Reference (Typ, True);
Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
Set_OK_To_Reference (Typ, False);
Replace_Type (Arg2);
-- OK, replacement complete, now we can add the expression
@ -4014,8 +4064,6 @@ package body Sem_Ch13 is
-- Initialize for construction of statement list
Expr := Empty;
FDecl := Empty;
FBody := Empty;
-- Return if already built or if type does not have predicates
@ -4043,16 +4091,6 @@ package body Sem_Ch13 is
if Present (Expr) then
-- Deal with static predicate case
if Ekind_In (Typ, E_Enumeration_Subtype,
E_Modular_Integer_Subtype,
E_Signed_Integer_Subtype)
and then Is_Static_Subtype (Typ)
then
Build_Static_Predicate (Typ, Expr, Object_Name);
end if;
-- Build function declaration
pragma Assert (Has_Predicates (Typ));
@ -4073,9 +4111,7 @@ package body Sem_Ch13 is
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc));
FDecl :=
Make_Subprogram_Declaration (Loc,
Specification => Spec);
FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
-- Build function body
@ -4104,6 +4140,21 @@ package body Sem_Ch13 is
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
-- Insert declaration before freeze node and body after
Insert_Before_And_Analyze (N, FDecl);
Insert_After_And_Analyze (N, FBody);
-- Deal with static predicate case
if Ekind_In (Typ, E_Enumeration_Subtype,
E_Modular_Integer_Subtype,
E_Signed_Integer_Subtype)
and then Is_Static_Subtype (Typ)
then
Build_Static_Predicate (Typ, Expr, Object_Name);
end if;
end if;
end Build_Predicate_Function;
@ -4908,6 +4959,13 @@ package body Sem_Ch13 is
Left_Opnd => Make_Identifier (Loc, Nam),
Right_Opnd => Empty,
Alternatives => New_Alts));
-- Resolve new expression in function context
Install_Formals (Predicate_Function (Typ));
Push_Scope (Predicate_Function (Typ));
Analyze_And_Resolve (Expr, Standard_Boolean);
Pop_Scope;
end if;
end;
end;

29
gcc/ada/sem_ch3.adb
View File

@ -3077,6 +3077,27 @@ package body Sem_Ch3 is
end if;
end if;
-- Deal with predicate check before we start to do major rewriting.
-- it is OK to initialize and then check the initialized value, since
-- the object goes out of scope if we get a predicate failure. Note
-- that we do this in the analyzer and not the expander because the
-- analyzer does some substantial rewriting in some cases.
-- We need a predicate check if the type has predicates, and if either
-- there is an initializing expression, or for default initialization
-- when we have at least one case of an explicit default initial value.
if not Suppress_Assignment_Checks (N)
and then Present (Predicate_Function (T))
and then
(Present (E)
or else
Is_Partially_Initialized_Type (T, Include_Implicit => False))
then
Insert_After (N,
Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
end if;
-- Case of unconstrained type
if Is_Indefinite_Subtype (T) then
@ -3846,7 +3867,13 @@ package body Sem_Ch3 is
-- If ancestor has predicates then so does the subtype, and in addition
-- we must delay the freeze to properly arrange predicate inheritance.
if Has_Predicates (T) then
-- The Ancestor_Type test is a big kludge, there seem to be cases in
-- which T = ID, so the above tests and assignments do nothing???
if Has_Predicates (T)
or else (Present (Ancestor_Subtype (T))
and then Has_Predicates (Ancestor_Subtype (T)))
then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
end if;

4
gcc/ada/sem_ch4.adb
View File

@ -2277,8 +2277,8 @@ package body Sem_Ch4 is
procedure Analyze_Membership_Op (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
L : constant Node_Id := Left_Opnd (N);
R : constant Node_Id := Right_Opnd (N);
Index : Interp_Index;
It : Interp;

17
gcc/ada/sem_util.adb
View File

@ -6859,22 +6859,22 @@ package body Sem_Util is
-----------------------------------
function Is_Partially_Initialized_Type
(Typ : Entity_Id;
Include_Null : Boolean := True) return Boolean
(Typ : Entity_Id;
Include_Implicit : Boolean := True) return Boolean
is
begin
if Is_Scalar_Type (Typ) then
return False;
elsif Is_Access_Type (Typ) then
return Include_Null;
return Include_Implicit;
elsif Is_Array_Type (Typ) then
-- If component type is partially initialized, so is array type
if Is_Partially_Initialized_Type
(Component_Type (Typ), Include_Null)
(Component_Type (Typ), Include_Implicit)
then
return True;
@ -6888,9 +6888,10 @@ package body Sem_Util is
elsif Is_Record_Type (Typ) then
-- A discriminated type is always partially initialized
-- A discriminated type is always partially initialized if in
-- all mode
if Has_Discriminants (Typ) then
if Has_Discriminants (Typ) and then Include_Implicit then
return True;
-- A tagged type is always partially initialized
@ -6929,7 +6930,7 @@ package body Sem_Util is
-- initialized, then the enclosing record type is also.
elsif Is_Partially_Initialized_Type
(Etype (Ent), Include_Null)
(Etype (Ent), Include_Implicit)
then
return True;
end if;
@ -6969,7 +6970,7 @@ package body Sem_Util is
if No (U) then
return True;
else
return Is_Partially_Initialized_Type (U, Include_Null);
return Is_Partially_Initialized_Type (U, Include_Implicit);
end if;
end;

15
gcc/ada/sem_util.ads
View File

@ -769,17 +769,20 @@ package Sem_Util is
-- conversions and hence variables.
function Is_Partially_Initialized_Type
(Typ : Entity_Id;
Include_Null : Boolean := True) return Boolean;
(Typ : Entity_Id;
Include_Implicit : Boolean := True) return Boolean;
-- Typ is a type entity. This function returns true if this type is partly
-- initialized, meaning that an object of the type is at least partly
-- initialized (in particular in the record case, that at least one
-- component has an initialization expression). Note that initialization
-- resulting from the use of pragma Normalized_Scalars does not count.
-- Include_Null controls the handling of access types, and components of
-- access types not explicitly initialized. If set to True, the default,
-- default initialization of access types counts as making the type be
-- partially initialized. If False, this does not count.
-- Include_Implicit controls whether implicit initialiation of access
-- values to null, and of discriminant values, is counted as making the
-- type be partially initialized. For the default setting of True, these
-- implicit cases do count, and discriminated types or types containing
-- access values not explicitly initialized will return True. Otherwise
-- if Include_Implicit is False, these cases do not count as making the
-- type be partially initialied.
function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
-- Determines if type T is a potentially persistent type. A potentially

5
gcc/ada/sem_warn.adb
View File

@ -3797,9 +3797,10 @@ package body Sem_Warn is
end if;
else
Error_Msg_Node_2 := Form;
Error_Msg_FE
("writable actual overlaps with actual for&?",
Act1, Form);
("writable actual for & overlaps with"
& " actual for&?", Act1, Form1);
end if;
end;
end if;