[multiple changes]
2010-10-25 Pascal Obry <obry@adacore.com> * adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get the timestamp. A bit faster than opening/closing the file. (__gnat_stat_to_attr): Remove kludge for Windows. (__gnat_file_exists_attr): Likewise. The timestamp is now retreived using GetFileAttributesEx as faster. 2010-10-25 Javier Miranda <miranda@adacore.com> * sem_ch3.adb (Derive_Interface_Subprogram): New subprogram. (Derive_Subprograms): For abstract private types transfer to the full view entities of uncovered interface primitives. Required because if the interface primitives are left in the private part of the package they will be decorated as hidden when the analysis of the enclosing package completes (and hence the interface primitive is not visible for dispatching calls). 2010-10-25 Matthew Heaney <heaney@adacore.com> * Makefile.rtl, impunit.adb: Added bounded set and bounded map containers. * a-crbltr.ads: Added declaration of generic package for bounded tree types. * a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads, a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb: New. 2010-10-25 Thomas Quinot <quinot@adacore.com> * sem_util.adb: Minor reformatting. * usage.adb: Fix usage line for -gnatwh. 2010-10-25 Thomas Quinot <quinot@adacore.com> * sem_ch12.adb (Analyze_Package_Instantiation): For an instantiation in an RCI spec, omit package body if instantiation comes from source, even as a nested package. * exp_dist.adb (Add_Calling_Stubs_To_Declarations, *_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of nested packages, package instantiations and subprogram instantiations. From-SVN: r165920
This commit is contained in:
Arnaud Charlet
parent
f6b5dc8e1f
commit
ff2efe85eb
@ -1,3 +1,46 @@
|
||||
2010-10-25 Pascal Obry <obry@adacore.com>
|
||||
|
||||
* adaint.c (__gnat_file_time_name_attr): Use GetFileAttributesEx to get
|
||||
the timestamp. A bit faster than opening/closing the file.
|
||||
(__gnat_stat_to_attr): Remove kludge for Windows.
|
||||
(__gnat_file_exists_attr): Likewise.
|
||||
The timestamp is now retreived using GetFileAttributesEx as faster.
|
||||
|
||||
2010-10-25 Javier Miranda <miranda@adacore.com>
|
||||
|
||||
* sem_ch3.adb (Derive_Interface_Subprogram): New subprogram.
|
||||
(Derive_Subprograms): For abstract private types transfer to the full
|
||||
view entities of uncovered interface primitives. Required because if
|
||||
the interface primitives are left in the private part of the package
|
||||
they will be decorated as hidden when the analysis of the enclosing
|
||||
package completes (and hence the interface primitive is not visible
|
||||
for dispatching calls).
|
||||
|
||||
2010-10-25 Matthew Heaney <heaney@adacore.com>
|
||||
|
||||
* Makefile.rtl, impunit.adb: Added bounded set and bounded map
|
||||
containers.
|
||||
* a-crbltr.ads: Added declaration of generic package for bounded tree
|
||||
types.
|
||||
* a-rbtgbo.ads, a-rbtgbo.adb, a-rbtgbk.ads, a-rbtgbk.adb, a-btgbso.ads,
|
||||
a-btgbso.adb, a-cborse.ads, a-cborse.adb, a-cborma.ads, a-cborma.adb:
|
||||
New.
|
||||
|
||||
2010-10-25 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sem_util.adb: Minor reformatting.
|
||||
* usage.adb: Fix usage line for -gnatwh.
|
||||
|
||||
2010-10-25 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* sem_ch12.adb (Analyze_Package_Instantiation): For an
|
||||
instantiation in an RCI spec, omit package body if instantiation comes
|
||||
from source, even as a nested
|
||||
package.
|
||||
* exp_dist.adb (Add_Calling_Stubs_To_Declarations,
|
||||
*_Support.Add_Receiving_Stubs_To_Declarations): Handle the case of
|
||||
nested packages, package instantiations and subprogram instantiations.
|
||||
|
||||
2010-10-25 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through
|
||||
|
||||
@ -79,12 +79,15 @@ GNATRTL_TASKING_OBJS= \
|
||||
# Objects needed for non-tasking.
|
||||
GNATRTL_NONTASKING_OBJS= \
|
||||
a-assert$(objext) \
|
||||
a-btgbso$(objext) \
|
||||
a-calari$(objext) \
|
||||
a-calcon$(objext) \
|
||||
a-caldel$(objext) \
|
||||
a-calend$(objext) \
|
||||
a-calfor$(objext) \
|
||||
a-catizo$(objext) \
|
||||
a-cborse$(objext) \
|
||||
a-cborma$(objext) \
|
||||
a-cdlili$(objext) \
|
||||
a-cgaaso$(objext) \
|
||||
a-cgarso$(objext) \
|
||||
@ -180,6 +183,8 @@ GNATRTL_NONTASKING_OBJS= \
|
||||
a-nuflra$(objext) \
|
||||
a-numaux$(objext) \
|
||||
a-numeri$(objext) \
|
||||
a-rbtgbo$(objext) \
|
||||
a-rbtgbk$(objext) \
|
||||
a-rbtgso$(objext) \
|
||||
a-scteio$(objext) \
|
||||
a-secain$(objext) \
|
||||
|
||||
605
gcc/ada/a-btgbso.adb
Normal file
605
gcc/ada/a-btgbso.adb
Normal file
@ -0,0 +1,605 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_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.Red_Black_Trees.Generic_Bounded_Set_Operations is
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
function Copy (Source : Set_Type) return Set_Type;
|
||||
|
||||
----------
|
||||
-- Copy --
|
||||
----------
|
||||
|
||||
function Copy (Source : Set_Type) return Set_Type is
|
||||
begin
|
||||
return Target : Set_Type (Source.Length) do
|
||||
Assign (Target => Target, Source => Source);
|
||||
end return;
|
||||
end Copy;
|
||||
|
||||
----------------
|
||||
-- Difference --
|
||||
----------------
|
||||
|
||||
procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is
|
||||
Tgt, Src : Count_Type;
|
||||
|
||||
TN : Nodes_Type renames Target.Nodes;
|
||||
SN : Nodes_Type renames Source.Nodes;
|
||||
|
||||
begin
|
||||
if Target'Address = Source'Address then
|
||||
if Target.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
Tree_Operations.Clear_Tree (Target);
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Source.Length = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Target.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
Tgt := Target.First;
|
||||
Src := Source.First;
|
||||
loop
|
||||
if Tgt = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Src = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Less (TN (Tgt), SN (Src)) then
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
elsif Is_Less (SN (Src), TN (Tgt)) then
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
|
||||
else
|
||||
declare
|
||||
X : constant Count_Type := Tgt;
|
||||
begin
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
Tree_Operations.Delete_Node_Sans_Free (Target, X);
|
||||
Tree_Operations.Free (Target, X);
|
||||
end;
|
||||
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
end if;
|
||||
end loop;
|
||||
end Set_Difference;
|
||||
|
||||
function Set_Difference (Left, Right : Set_Type) return Set_Type is
|
||||
L_Node : Count_Type;
|
||||
R_Node : Count_Type;
|
||||
|
||||
Dst_Node : Count_Type;
|
||||
pragma Warnings (Off, Dst_Node);
|
||||
|
||||
begin
|
||||
if Left'Address = Right'Address then
|
||||
return S : Set_Type (0); -- Empty set
|
||||
end if;
|
||||
|
||||
if Left.Length = 0 then
|
||||
return S : Set_Type (0); -- Empty set
|
||||
end if;
|
||||
|
||||
if Right.Length = 0 then
|
||||
return Copy (Left);
|
||||
end if;
|
||||
|
||||
return Result : Set_Type (Left.Length) do
|
||||
L_Node := Left.First;
|
||||
R_Node := Right.First;
|
||||
loop
|
||||
if L_Node = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if R_Node = 0 then
|
||||
while L_Node /= 0 loop
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Left.Nodes (L_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
end loop;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Left.Nodes (L_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
|
||||
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
|
||||
else
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
end if;
|
||||
end loop;
|
||||
end return;
|
||||
end Set_Difference;
|
||||
|
||||
------------------
|
||||
-- Intersection --
|
||||
------------------
|
||||
|
||||
procedure Set_Intersection
|
||||
(Target : in out Set_Type;
|
||||
Source : Set_Type)
|
||||
is
|
||||
Tgt : Count_Type;
|
||||
Src : Count_Type;
|
||||
|
||||
begin
|
||||
if Target'Address = Source'Address then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Target.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
if Source.Length = 0 then
|
||||
Tree_Operations.Clear_Tree (Target);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Tgt := Target.First;
|
||||
Src := Source.First;
|
||||
while Tgt /= 0
|
||||
and then Src /= 0
|
||||
loop
|
||||
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
|
||||
declare
|
||||
X : constant Count_Type := Tgt;
|
||||
begin
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
Tree_Operations.Delete_Node_Sans_Free (Target, X);
|
||||
Tree_Operations.Free (Target, X);
|
||||
end;
|
||||
|
||||
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
|
||||
else
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
while Tgt /= 0 loop
|
||||
declare
|
||||
X : constant Count_Type := Tgt;
|
||||
begin
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
Tree_Operations.Delete_Node_Sans_Free (Target, X);
|
||||
Tree_Operations.Free (Target, X);
|
||||
end;
|
||||
end loop;
|
||||
end Set_Intersection;
|
||||
|
||||
function Set_Intersection (Left, Right : Set_Type) return Set_Type is
|
||||
L_Node : Count_Type;
|
||||
R_Node : Count_Type;
|
||||
|
||||
Dst_Node : Count_Type;
|
||||
pragma Warnings (Off, Dst_Node);
|
||||
|
||||
begin
|
||||
if Left'Address = Right'Address then
|
||||
return Copy (Left);
|
||||
end if;
|
||||
|
||||
return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do
|
||||
L_Node := Left.First;
|
||||
R_Node := Right.First;
|
||||
loop
|
||||
if L_Node = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if R_Node = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
|
||||
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
|
||||
else
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Left.Nodes (L_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
end if;
|
||||
end loop;
|
||||
end return;
|
||||
end Set_Intersection;
|
||||
|
||||
---------------
|
||||
-- Is_Subset --
|
||||
---------------
|
||||
|
||||
function Set_Subset
|
||||
(Subset : Set_Type;
|
||||
Of_Set : Set_Type) return Boolean
|
||||
is
|
||||
Subset_Node : Count_Type;
|
||||
Set_Node : Count_Type;
|
||||
|
||||
begin
|
||||
if Subset'Address = Of_Set'Address then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
if Subset.Length > Of_Set.Length then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Subset_Node := Subset.First;
|
||||
Set_Node := Of_Set.First;
|
||||
loop
|
||||
if Set_Node = 0 then
|
||||
return Subset_Node = 0;
|
||||
end if;
|
||||
|
||||
if Subset_Node = 0 then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
if Is_Less (Subset.Nodes (Subset_Node), Of_Set.Nodes (Set_Node)) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
if Is_Less (Of_Set.Nodes (Set_Node), Subset.Nodes (Subset_Node)) then
|
||||
Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
|
||||
else
|
||||
Set_Node := Tree_Operations.Next (Of_Set, Set_Node);
|
||||
Subset_Node := Tree_Operations.Next (Subset, Subset_Node);
|
||||
end if;
|
||||
end loop;
|
||||
end Set_Subset;
|
||||
|
||||
-------------
|
||||
-- Overlap --
|
||||
-------------
|
||||
|
||||
function Set_Overlap (Left, Right : Set_Type) return Boolean is
|
||||
L_Node : Count_Type;
|
||||
R_Node : Count_Type;
|
||||
|
||||
begin
|
||||
if Left'Address = Right'Address then
|
||||
return Left.Length /= 0;
|
||||
end if;
|
||||
|
||||
L_Node := Left.First;
|
||||
R_Node := Right.First;
|
||||
loop
|
||||
if L_Node = 0
|
||||
or else R_Node = 0
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
|
||||
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
|
||||
else
|
||||
return True;
|
||||
end if;
|
||||
end loop;
|
||||
end Set_Overlap;
|
||||
|
||||
--------------------------
|
||||
-- Symmetric_Difference --
|
||||
--------------------------
|
||||
|
||||
procedure Set_Symmetric_Difference
|
||||
(Target : in out Set_Type;
|
||||
Source : Set_Type)
|
||||
is
|
||||
Tgt : Count_Type;
|
||||
Src : Count_Type;
|
||||
|
||||
New_Tgt_Node : Count_Type;
|
||||
pragma Warnings (Off, New_Tgt_Node);
|
||||
|
||||
begin
|
||||
if Target.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
if Target'Address = Source'Address then
|
||||
Tree_Operations.Clear_Tree (Target);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Tgt := Target.First;
|
||||
Src := Source.First;
|
||||
loop
|
||||
if Tgt = 0 then
|
||||
while Src /= 0 loop
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Target,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Source.Nodes (Src),
|
||||
Dst_Node => New_Tgt_Node);
|
||||
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
end loop;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Src = 0 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Target,
|
||||
Dst_Hint => Tgt,
|
||||
Src_Node => Source.Nodes (Src),
|
||||
Dst_Node => New_Tgt_Node);
|
||||
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
|
||||
else
|
||||
declare
|
||||
X : constant Count_Type := Tgt;
|
||||
begin
|
||||
Tgt := Tree_Operations.Next (Target, Tgt);
|
||||
|
||||
Tree_Operations.Delete_Node_Sans_Free (Target, X);
|
||||
Tree_Operations.Free (Target, X);
|
||||
end;
|
||||
|
||||
Src := Tree_Operations.Next (Source, Src);
|
||||
end if;
|
||||
end loop;
|
||||
end Set_Symmetric_Difference;
|
||||
|
||||
function Set_Symmetric_Difference
|
||||
(Left, Right : Set_Type) return Set_Type
|
||||
is
|
||||
L_Node : Count_Type;
|
||||
R_Node : Count_Type;
|
||||
|
||||
Dst_Node : Count_Type;
|
||||
pragma Warnings (Off, Dst_Node);
|
||||
|
||||
begin
|
||||
if Left'Address = Right'Address then
|
||||
return S : Set_Type (0); -- Empty set
|
||||
end if;
|
||||
|
||||
if Right.Length = 0 then
|
||||
return Copy (Left);
|
||||
end if;
|
||||
|
||||
if Left.Length = 0 then
|
||||
return Copy (Right);
|
||||
end if;
|
||||
|
||||
return Result : Set_Type (Left.Length + Right.Length) do
|
||||
L_Node := Left.First;
|
||||
R_Node := Right.First;
|
||||
loop
|
||||
if L_Node = 0 then
|
||||
while R_Node /= 0 loop
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Right.Nodes (R_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
end loop;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
if R_Node = 0 then
|
||||
while L_Node /= 0 loop
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Left.Nodes (L_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
end loop;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Left.Nodes (L_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
|
||||
elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => 0,
|
||||
Src_Node => Right.Nodes (R_Node),
|
||||
Dst_Node => Dst_Node);
|
||||
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
|
||||
else
|
||||
L_Node := Tree_Operations.Next (Left, L_Node);
|
||||
R_Node := Tree_Operations.Next (Right, R_Node);
|
||||
end if;
|
||||
end loop;
|
||||
end return;
|
||||
end Set_Symmetric_Difference;
|
||||
|
||||
-----------
|
||||
-- Union --
|
||||
-----------
|
||||
|
||||
procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is
|
||||
Hint : Count_Type := 0;
|
||||
|
||||
procedure Process (Node : Count_Type);
|
||||
pragma Inline (Process);
|
||||
|
||||
procedure Iterate is new Tree_Operations.Generic_Iteration (Process);
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
||||
procedure Process (Node : Count_Type) is
|
||||
begin
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Target,
|
||||
Dst_Hint => Hint,
|
||||
Src_Node => Source.Nodes (Node),
|
||||
Dst_Node => Hint);
|
||||
end Process;
|
||||
|
||||
-- Start of processing for Union
|
||||
|
||||
begin
|
||||
if Target'Address = Source'Address then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Target.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
-- Note that there's no way to decide apriori whether the
|
||||
-- target has enough capacity for the union with source.
|
||||
-- We cannot simply compare the sum of the existing lengths
|
||||
-- to the capacity of the target, because equivalent items
|
||||
-- from source are not included in the union.
|
||||
|
||||
Iterate (Source);
|
||||
end Set_Union;
|
||||
|
||||
function Set_Union (Left, Right : Set_Type) return Set_Type is
|
||||
begin
|
||||
if Left'Address = Right'Address then
|
||||
return Copy (Left);
|
||||
end if;
|
||||
|
||||
if Left.Length = 0 then
|
||||
return Copy (Right);
|
||||
end if;
|
||||
|
||||
if Right.Length = 0 then
|
||||
return Copy (Left);
|
||||
end if;
|
||||
|
||||
return Result : Set_Type (Left.Length + Right.Length) do
|
||||
Assign (Target => Result, Source => Left);
|
||||
|
||||
Insert_Right : declare
|
||||
Hint : Count_Type := 0;
|
||||
|
||||
procedure Process (Node : Count_Type);
|
||||
pragma Inline (Process);
|
||||
|
||||
procedure Iterate is
|
||||
new Tree_Operations.Generic_Iteration (Process);
|
||||
|
||||
-------------
|
||||
-- Process --
|
||||
-------------
|
||||
|
||||
procedure Process (Node : Count_Type) is
|
||||
begin
|
||||
Insert_With_Hint
|
||||
(Dst_Set => Result,
|
||||
Dst_Hint => Hint,
|
||||
Src_Node => Right.Nodes (Node),
|
||||
Dst_Node => Hint);
|
||||
end Process;
|
||||
|
||||
-- Start of processing for Insert_Right
|
||||
|
||||
begin
|
||||
Iterate (Right);
|
||||
end Insert_Right;
|
||||
end return;
|
||||
end Set_Union;
|
||||
|
||||
end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
|
||||
103
gcc/ada/a-btgbso.ads
Normal file
103
gcc/ada/a-btgbso.ads
Normal file
@ -0,0 +1,103 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_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. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Tree_Type is used to implement ordered containers. This package declares
|
||||
-- set-based tree operations.
|
||||
|
||||
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
|
||||
|
||||
generic
|
||||
with package Tree_Operations is new Generic_Bounded_Operations (<>);
|
||||
|
||||
type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private;
|
||||
|
||||
use Tree_Operations.Tree_Types;
|
||||
|
||||
with procedure Assign (Target : in out Set_Type; Source : Set_Type);
|
||||
|
||||
with procedure Insert_With_Hint
|
||||
(Dst_Set : in out Set_Type;
|
||||
Dst_Hint : Count_Type;
|
||||
Src_Node : Node_Type;
|
||||
Dst_Node : out Count_Type);
|
||||
|
||||
with function Is_Less (Left, Right : Node_Type) return Boolean;
|
||||
|
||||
package Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is
|
||||
pragma Pure;
|
||||
|
||||
procedure Set_Union (Target : in out Set_Type; Source : Set_Type);
|
||||
-- Attempts to insert each element of Source in Target. If Target is
|
||||
-- busy then Program_Error is raised. We say "attempts" here because
|
||||
-- if these are unique-element sets, then the insertion should fail
|
||||
-- (not insert a new item) when the insertion item from Source is
|
||||
-- equivalent to an item already in Target. If these are multisets
|
||||
-- then of course the attempt should always succeed.
|
||||
|
||||
function Set_Union (Left, Right : Set_Type) return Set_Type;
|
||||
-- Makes a copy of Left, and attempts to insert each element of
|
||||
-- Right into the copy, then returns the copy.
|
||||
|
||||
procedure Set_Intersection (Target : in out Set_Type; Source : Set_Type);
|
||||
-- Removes elements from Target that are not equivalent to items in
|
||||
-- Source. If Target is busy then Program_Error is raised.
|
||||
|
||||
function Set_Intersection (Left, Right : Set_Type) return Set_Type;
|
||||
-- Returns a set comprising all the items in Left equivalent to items in
|
||||
-- Right.
|
||||
|
||||
procedure Set_Difference (Target : in out Set_Type; Source : Set_Type);
|
||||
-- Removes elements from Target that are equivalent to items in Source. If
|
||||
-- Target is busy then Program_Error is raised.
|
||||
|
||||
function Set_Difference (Left, Right : Set_Type) return Set_Type;
|
||||
-- Returns a set comprising all the items in Left not equivalent to items
|
||||
-- in Right.
|
||||
|
||||
procedure Set_Symmetric_Difference
|
||||
(Target : in out Set_Type;
|
||||
Source : Set_Type);
|
||||
-- Removes from Target elements that are equivalent to items in Source,
|
||||
-- and inserts into Target items from Source not equivalent elements in
|
||||
-- Target. If Target is busy then Program_Error is raised.
|
||||
|
||||
function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type;
|
||||
-- Returns a set comprising the union of the elements in Left not
|
||||
-- equivalent to items in Right, and the elements in Right not equivalent
|
||||
-- to items in Left.
|
||||
|
||||
function Set_Subset (Subset : Set_Type; Of_Set : Set_Type) return Boolean;
|
||||
-- Returns False if Subset contains at least one element not equivalent to
|
||||
-- any item in Of_Set; returns True otherwise.
|
||||
|
||||
function Set_Overlap (Left, Right : Set_Type) return Boolean;
|
||||
-- Returns True if at least one element of Left is equivalent to an item in
|
||||
-- Right; returns False otherwise.
|
||||
|
||||
end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations;
|
||||
1348
gcc/ada/a-cborma.adb
Normal file
1348
gcc/ada/a-cborma.adb
Normal file
File diff suppressed because it is too large
Load Diff
244
gcc/ada/a-cborma.ads
Normal file
244
gcc/ada/a-cborma.ads
Normal file
@ -0,0 +1,244 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R 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.Red_Black_Trees;
|
||||
private with Ada.Streams;
|
||||
|
||||
generic
|
||||
type Key_Type is private;
|
||||
type Element_Type is private;
|
||||
|
||||
with function "<" (Left, Right : Key_Type) return Boolean is <>;
|
||||
with function "=" (Left, Right : Element_Type) return Boolean is <>;
|
||||
|
||||
package Ada.Containers.Bounded_Ordered_Maps is
|
||||
pragma Pure;
|
||||
pragma Remote_Types;
|
||||
|
||||
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
|
||||
|
||||
type Map (Capacity : Count_Type) is tagged private;
|
||||
pragma Preelaborable_Initialization (Map);
|
||||
|
||||
type Cursor is private;
|
||||
pragma Preelaborable_Initialization (Cursor);
|
||||
|
||||
Empty_Map : constant Map;
|
||||
|
||||
No_Element : constant Cursor;
|
||||
|
||||
function "=" (Left, Right : Map) return Boolean;
|
||||
|
||||
function Length (Container : Map) return Count_Type;
|
||||
|
||||
function Is_Empty (Container : Map) return Boolean;
|
||||
|
||||
procedure Clear (Container : in out Map);
|
||||
|
||||
function Key (Position : Cursor) return Key_Type;
|
||||
|
||||
function Element (Position : Cursor) return Element_Type;
|
||||
|
||||
procedure Replace_Element
|
||||
(Container : in out Map;
|
||||
Position : Cursor;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Query_Element
|
||||
(Position : Cursor;
|
||||
Process : not null access
|
||||
procedure (Key : Key_Type; Element : Element_Type));
|
||||
|
||||
procedure Update_Element
|
||||
(Container : in out Map;
|
||||
Position : Cursor;
|
||||
Process : not null access
|
||||
procedure (Key : Key_Type; Element : in out Element_Type));
|
||||
|
||||
procedure Assign (Target : in out Map; Source : Map);
|
||||
|
||||
function Copy (Source : Map; Capacity : Count_Type := 0) return Map;
|
||||
|
||||
procedure Move (Target : in out Map; Source : in out Map);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Map;
|
||||
Key : Key_Type;
|
||||
New_Item : Element_Type;
|
||||
Position : out Cursor;
|
||||
Inserted : out Boolean);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Map;
|
||||
Key : Key_Type;
|
||||
Position : out Cursor;
|
||||
Inserted : out Boolean);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Map;
|
||||
Key : Key_Type;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Include
|
||||
(Container : in out Map;
|
||||
Key : Key_Type;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Replace
|
||||
(Container : in out Map;
|
||||
Key : Key_Type;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Exclude (Container : in out Map; Key : Key_Type);
|
||||
|
||||
procedure Delete (Container : in out Map; Key : Key_Type);
|
||||
|
||||
procedure Delete (Container : in out Map; Position : in out Cursor);
|
||||
|
||||
procedure Delete_First (Container : in out Map);
|
||||
|
||||
procedure Delete_Last (Container : in out Map);
|
||||
|
||||
function First (Container : Map) return Cursor;
|
||||
|
||||
function First_Element (Container : Map) return Element_Type;
|
||||
|
||||
function First_Key (Container : Map) return Key_Type;
|
||||
|
||||
function Last (Container : Map) return Cursor;
|
||||
|
||||
function Last_Element (Container : Map) return Element_Type;
|
||||
|
||||
function Last_Key (Container : Map) return Key_Type;
|
||||
|
||||
function Next (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Next (Position : in out Cursor);
|
||||
|
||||
function Previous (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Previous (Position : in out Cursor);
|
||||
|
||||
function Find (Container : Map; Key : Key_Type) return Cursor;
|
||||
|
||||
function Element (Container : Map; Key : Key_Type) return Element_Type;
|
||||
|
||||
function Floor (Container : Map; Key : Key_Type) return Cursor;
|
||||
|
||||
function Ceiling (Container : Map; Key : Key_Type) return Cursor;
|
||||
|
||||
function Contains (Container : Map; Key : Key_Type) return Boolean;
|
||||
|
||||
function Has_Element (Position : Cursor) return Boolean;
|
||||
|
||||
function "<" (Left, Right : Cursor) return Boolean;
|
||||
|
||||
function ">" (Left, Right : Cursor) return Boolean;
|
||||
|
||||
function "<" (Left : Cursor; Right : Key_Type) return Boolean;
|
||||
|
||||
function ">" (Left : Cursor; Right : Key_Type) return Boolean;
|
||||
|
||||
function "<" (Left : Key_Type; Right : Cursor) return Boolean;
|
||||
|
||||
function ">" (Left : Key_Type; Right : Cursor) return Boolean;
|
||||
|
||||
procedure Iterate
|
||||
(Container : Map;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
procedure Reverse_Iterate
|
||||
(Container : Map;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
private
|
||||
|
||||
pragma Inline (Next);
|
||||
pragma Inline (Previous);
|
||||
|
||||
type Node_Type is record
|
||||
Parent : Count_Type;
|
||||
Left : Count_Type;
|
||||
Right : Count_Type;
|
||||
Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
|
||||
Key : Key_Type;
|
||||
Element : Element_Type;
|
||||
end record;
|
||||
|
||||
package Tree_Types is
|
||||
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
|
||||
|
||||
type Map (Capacity : Count_Type) is
|
||||
new Tree_Types.Tree_Type (Capacity) with null record;
|
||||
|
||||
type Map_Access is access all Map;
|
||||
for Map_Access'Storage_Size use 0;
|
||||
|
||||
use Red_Black_Trees;
|
||||
use Tree_Types;
|
||||
use Ada.Streams;
|
||||
|
||||
type Cursor is record
|
||||
Container : Map_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 := Cursor'(null, 0);
|
||||
|
||||
procedure Write
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Container : Map);
|
||||
|
||||
for Map'Write use Write;
|
||||
|
||||
procedure Read
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Container : out Map);
|
||||
|
||||
for Map'Read use Read;
|
||||
|
||||
Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0);
|
||||
|
||||
end Ada.Containers.Bounded_Ordered_Maps;
|
||||
1718
gcc/ada/a-cborse.adb
Normal file
1718
gcc/ada/a-cborse.adb
Normal file
File diff suppressed because it is too large
Load Diff
294
gcc/ada/a-cborse.ads
Normal file
294
gcc/ada/a-cborse.ads
Normal file
@ -0,0 +1,294 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R 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.Red_Black_Trees;
|
||||
private with Ada.Streams;
|
||||
|
||||
generic
|
||||
type Element_Type is private;
|
||||
|
||||
with function "<" (Left, Right : Element_Type) return Boolean is <>;
|
||||
with function "=" (Left, Right : Element_Type) return Boolean is <>;
|
||||
|
||||
package Ada.Containers.Bounded_Ordered_Sets is
|
||||
pragma Pure;
|
||||
pragma Remote_Types;
|
||||
|
||||
function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
|
||||
|
||||
type Set (Capacity : Count_Type) is tagged private;
|
||||
pragma Preelaborable_Initialization (Set);
|
||||
|
||||
type Cursor is private;
|
||||
pragma Preelaborable_Initialization (Cursor);
|
||||
|
||||
Empty_Set : constant Set;
|
||||
|
||||
No_Element : constant Cursor;
|
||||
|
||||
function "=" (Left, Right : Set) return Boolean;
|
||||
|
||||
function Equivalent_Sets (Left, Right : Set) return Boolean;
|
||||
|
||||
function To_Set (New_Item : Element_Type) return Set;
|
||||
|
||||
function Length (Container : Set) return Count_Type;
|
||||
|
||||
function Is_Empty (Container : Set) return Boolean;
|
||||
|
||||
procedure Clear (Container : in out Set);
|
||||
|
||||
function Element (Position : Cursor) return Element_Type;
|
||||
|
||||
procedure Replace_Element
|
||||
(Container : in out Set;
|
||||
Position : Cursor;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Query_Element
|
||||
(Position : Cursor;
|
||||
Process : not null access procedure (Element : Element_Type));
|
||||
|
||||
procedure Assign (Target : in out Set; Source : Set);
|
||||
|
||||
function Copy (Source : Set; Capacity : Count_Type := 0) return Set;
|
||||
|
||||
procedure Move (Target : in out Set; Source : in out Set);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Set;
|
||||
New_Item : Element_Type;
|
||||
Position : out Cursor;
|
||||
Inserted : out Boolean);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Set;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Include
|
||||
(Container : in out Set;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Replace
|
||||
(Container : in out Set;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Exclude
|
||||
(Container : in out Set;
|
||||
Item : Element_Type);
|
||||
|
||||
procedure Delete
|
||||
(Container : in out Set;
|
||||
Item : Element_Type);
|
||||
|
||||
procedure Delete
|
||||
(Container : in out Set;
|
||||
Position : in out Cursor);
|
||||
|
||||
procedure Delete_First (Container : in out Set);
|
||||
|
||||
procedure Delete_Last (Container : in out Set);
|
||||
|
||||
procedure Union (Target : in out Set; Source : Set);
|
||||
|
||||
function Union (Left, Right : Set) return Set;
|
||||
|
||||
function "or" (Left, Right : Set) return Set renames Union;
|
||||
|
||||
procedure Intersection (Target : in out Set; Source : Set);
|
||||
|
||||
function Intersection (Left, Right : Set) return Set;
|
||||
|
||||
function "and" (Left, Right : Set) return Set renames Intersection;
|
||||
|
||||
procedure Difference (Target : in out Set; Source : Set);
|
||||
|
||||
function Difference (Left, Right : Set) return Set;
|
||||
|
||||
function "-" (Left, Right : Set) return Set renames Difference;
|
||||
|
||||
procedure Symmetric_Difference (Target : in out Set; Source : Set);
|
||||
|
||||
function Symmetric_Difference (Left, Right : Set) return Set;
|
||||
|
||||
function "xor" (Left, Right : Set) return Set renames Symmetric_Difference;
|
||||
|
||||
function Overlap (Left, Right : Set) return Boolean;
|
||||
|
||||
function Is_Subset (Subset : Set; Of_Set : Set) return Boolean;
|
||||
|
||||
function First (Container : Set) return Cursor;
|
||||
|
||||
function First_Element (Container : Set) return Element_Type;
|
||||
|
||||
function Last (Container : Set) return Cursor;
|
||||
|
||||
function Last_Element (Container : Set) return Element_Type;
|
||||
|
||||
function Next (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Next (Position : in out Cursor);
|
||||
|
||||
function Previous (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Previous (Position : in out Cursor);
|
||||
|
||||
function Find (Container : Set; Item : Element_Type) return Cursor;
|
||||
|
||||
function Floor (Container : Set; Item : Element_Type) return Cursor;
|
||||
|
||||
function Ceiling (Container : Set; Item : Element_Type) return Cursor;
|
||||
|
||||
function Contains (Container : Set; Item : Element_Type) return Boolean;
|
||||
|
||||
function Has_Element (Position : Cursor) return Boolean;
|
||||
|
||||
function "<" (Left, Right : Cursor) return Boolean;
|
||||
|
||||
function ">" (Left, Right : Cursor) return Boolean;
|
||||
|
||||
function "<" (Left : Cursor; Right : Element_Type) return Boolean;
|
||||
|
||||
function ">" (Left : Cursor; Right : Element_Type) return Boolean;
|
||||
|
||||
function "<" (Left : Element_Type; Right : Cursor) return Boolean;
|
||||
|
||||
function ">" (Left : Element_Type; Right : Cursor) return Boolean;
|
||||
|
||||
procedure Iterate
|
||||
(Container : Set;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
procedure Reverse_Iterate
|
||||
(Container : Set;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
generic
|
||||
type Key_Type (<>) is private;
|
||||
|
||||
with function Key (Element : Element_Type) return Key_Type;
|
||||
|
||||
with function "<" (Left, Right : Key_Type) return Boolean is <>;
|
||||
|
||||
package Generic_Keys is
|
||||
|
||||
function Equivalent_Keys (Left, Right : Key_Type) return Boolean;
|
||||
|
||||
function Key (Position : Cursor) return Key_Type;
|
||||
|
||||
function Element (Container : Set; Key : Key_Type) return Element_Type;
|
||||
|
||||
procedure Replace
|
||||
(Container : in out Set;
|
||||
Key : Key_Type;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Exclude (Container : in out Set; Key : Key_Type);
|
||||
|
||||
procedure Delete (Container : in out Set; Key : Key_Type);
|
||||
|
||||
function Find (Container : Set; Key : Key_Type) return Cursor;
|
||||
|
||||
function Floor (Container : Set; Key : Key_Type) return Cursor;
|
||||
|
||||
function Ceiling (Container : Set; Key : Key_Type) return Cursor;
|
||||
|
||||
function Contains (Container : Set; Key : Key_Type) return Boolean;
|
||||
|
||||
procedure Update_Element_Preserving_Key
|
||||
(Container : in out Set;
|
||||
Position : Cursor;
|
||||
Process : not null access
|
||||
procedure (Element : in out Element_Type));
|
||||
|
||||
end Generic_Keys;
|
||||
|
||||
private
|
||||
|
||||
pragma Inline (Next);
|
||||
pragma Inline (Previous);
|
||||
|
||||
type Node_Type is record
|
||||
Parent : Count_Type;
|
||||
Left : Count_Type;
|
||||
Right : Count_Type;
|
||||
Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red;
|
||||
Element : Element_Type;
|
||||
end record;
|
||||
|
||||
package Tree_Types is
|
||||
new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type);
|
||||
|
||||
type Set (Capacity : Count_Type) is
|
||||
new Tree_Types.Tree_Type (Capacity) with null record;
|
||||
|
||||
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;
|
||||
|
||||
use Tree_Types;
|
||||
use Ada.Streams;
|
||||
|
||||
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 := Cursor'(null, 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 := Set'(Tree_Type with Capacity => 0);
|
||||
|
||||
end Ada.Containers.Bounded_Ordered_Sets;
|
||||
@ -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- --
|
||||
@ -48,4 +48,21 @@ package Ada.Containers.Red_Black_Trees is
|
||||
end record;
|
||||
end Generic_Tree_Types;
|
||||
|
||||
generic
|
||||
type Node_Type is private;
|
||||
package Generic_Bounded_Tree_Types is
|
||||
type Nodes_Type is array (Count_Type range <>) of Node_Type;
|
||||
|
||||
type Tree_Type (Capacity : Count_Type) is tagged record
|
||||
First : Count_Type := 0;
|
||||
Last : Count_Type := 0;
|
||||
Root : Count_Type := 0;
|
||||
Length : Count_Type := 0;
|
||||
Busy : Natural := 0;
|
||||
Lock : Natural := 0;
|
||||
Free : Count_Type'Base := -1;
|
||||
Nodes : Nodes_Type (1 .. Capacity);
|
||||
end record;
|
||||
end Generic_Bounded_Tree_Types;
|
||||
|
||||
end Ada.Containers.Red_Black_Trees;
|
||||
|
||||
599
gcc/ada/a-rbtgbk.adb
Normal file
599
gcc/ada/a-rbtgbk.adb
Normal file
@ -0,0 +1,599 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.CONTAINERS.RED_BLACK_TREES.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.Red_Black_Trees.Generic_Bounded_Keys is
|
||||
|
||||
package Ops renames Tree_Operations;
|
||||
|
||||
-------------
|
||||
-- Ceiling --
|
||||
-------------
|
||||
|
||||
-- AKA Lower_Bound
|
||||
|
||||
function Ceiling
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
|
||||
X := Tree.Root;
|
||||
while X /= 0 loop
|
||||
if Is_Greater_Key_Node (Key, N (X)) then
|
||||
X := Ops.Right (N (X));
|
||||
else
|
||||
Y := X;
|
||||
X := Ops.Left (N (X));
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return Y;
|
||||
end Ceiling;
|
||||
|
||||
----------
|
||||
-- Find --
|
||||
----------
|
||||
|
||||
function Find
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
|
||||
X := Tree.Root;
|
||||
while X /= 0 loop
|
||||
if Is_Greater_Key_Node (Key, N (X)) then
|
||||
X := Ops.Right (N (X));
|
||||
else
|
||||
Y := X;
|
||||
X := Ops.Left (N (X));
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Y = 0 then
|
||||
return 0;
|
||||
end if;
|
||||
|
||||
if Is_Less_Key_Node (Key, N (Y)) then
|
||||
return 0;
|
||||
end if;
|
||||
|
||||
return Y;
|
||||
end Find;
|
||||
|
||||
-----------
|
||||
-- Floor --
|
||||
-----------
|
||||
|
||||
function Floor
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
|
||||
X := Tree.Root;
|
||||
while X /= 0 loop
|
||||
if Is_Less_Key_Node (Key, N (X)) then
|
||||
X := Ops.Left (N (X));
|
||||
else
|
||||
Y := X;
|
||||
X := Ops.Right (N (X));
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return Y;
|
||||
end Floor;
|
||||
|
||||
--------------------------------
|
||||
-- Generic_Conditional_Insert --
|
||||
--------------------------------
|
||||
|
||||
procedure Generic_Conditional_Insert
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type;
|
||||
Inserted : out Boolean)
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
|
||||
X := Tree.Root;
|
||||
Inserted := True;
|
||||
while X /= 0 loop
|
||||
Y := X;
|
||||
Inserted := Is_Less_Key_Node (Key, N (X));
|
||||
X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X)));
|
||||
end loop;
|
||||
|
||||
-- If Inserted is True, then this means either that Tree is
|
||||
-- empty, or there was a least one node (strictly) greater than
|
||||
-- Key. Otherwise, it means that Key is equal to or greater than
|
||||
-- every node.
|
||||
|
||||
if Inserted then
|
||||
if Y = Tree.First then
|
||||
Insert_Post (Tree, Y, True, Node);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Node := Ops.Previous (Tree, Y);
|
||||
|
||||
else
|
||||
Node := Y;
|
||||
end if;
|
||||
|
||||
-- Here Node has a value that is less than or equal to Key. We
|
||||
-- now have to resolve whether Key is equal to or greater than
|
||||
-- Node, which determines whether the insertion succeeds.
|
||||
|
||||
if Is_Greater_Key_Node (Key, N (Node)) then
|
||||
Insert_Post (Tree, Y, Inserted, Node);
|
||||
Inserted := True;
|
||||
return;
|
||||
end if;
|
||||
|
||||
Inserted := False;
|
||||
end Generic_Conditional_Insert;
|
||||
|
||||
------------------------------------------
|
||||
-- Generic_Conditional_Insert_With_Hint --
|
||||
------------------------------------------
|
||||
|
||||
procedure Generic_Conditional_Insert_With_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Position : Count_Type;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type;
|
||||
Inserted : out Boolean)
|
||||
is
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
-- The purpose of a hint is to avoid a search from the root of
|
||||
-- tree. If we have it hint it means we only need to traverse the
|
||||
-- subtree rooted at the hint to find the nearest neighbor. Note
|
||||
-- that finding the neighbor means merely walking the tree; this
|
||||
-- is not a search and the only comparisons that occur are with
|
||||
-- the hint and its neighbor.
|
||||
|
||||
-- If Position is 0, this is interpreted to mean that Key is
|
||||
-- large relative to the nodes in the tree. If the tree is empty,
|
||||
-- or Key is greater than the last node in the tree, then we're
|
||||
-- done; otherwise the hint was "wrong" and we must search.
|
||||
|
||||
if Position = 0 then -- largest
|
||||
if Tree.Last = 0
|
||||
or else Is_Greater_Key_Node (Key, N (Tree.Last))
|
||||
then
|
||||
Insert_Post (Tree, Tree.Last, False, Node);
|
||||
Inserted := True;
|
||||
else
|
||||
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
pragma Assert (Tree.Length > 0);
|
||||
|
||||
-- A hint can either name the node that immediately follows Key,
|
||||
-- or immediately precedes Key. We first test whether Key is
|
||||
-- less than the hint, and if so we compare Key to the node that
|
||||
-- precedes the hint. If Key is both less than the hint and
|
||||
-- greater than the hint's preceding neighbor, then we're done;
|
||||
-- otherwise we must search.
|
||||
|
||||
-- Note also that a hint can either be an anterior node or a leaf
|
||||
-- node. A new node is always inserted at the bottom of the tree
|
||||
-- (at least prior to rebalancing), becoming the new left or
|
||||
-- right child of leaf node (which prior to the insertion must
|
||||
-- necessarily be null, since this is a leaf). If the hint names
|
||||
-- an anterior node then its neighbor must be a leaf, and so
|
||||
-- (here) we insert after the neighbor. If the hint names a leaf
|
||||
-- then its neighbor must be anterior and so we insert before the
|
||||
-- hint.
|
||||
|
||||
if Is_Less_Key_Node (Key, N (Position)) then
|
||||
declare
|
||||
Before : constant Count_Type := Ops.Previous (Tree, Position);
|
||||
|
||||
begin
|
||||
if Before = 0 then
|
||||
Insert_Post (Tree, Tree.First, True, Node);
|
||||
Inserted := True;
|
||||
|
||||
elsif Is_Greater_Key_Node (Key, N (Before)) then
|
||||
if Ops.Right (N (Before)) = 0 then
|
||||
Insert_Post (Tree, Before, False, Node);
|
||||
else
|
||||
Insert_Post (Tree, Position, True, Node);
|
||||
end if;
|
||||
|
||||
Inserted := True;
|
||||
|
||||
else
|
||||
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- We know that Key isn't less than the hint so we try again,
|
||||
-- this time to see if it's greater than the hint. If so we
|
||||
-- compare Key to the node that follows the hint. If Key is both
|
||||
-- greater than the hint and less than the hint's next neighbor,
|
||||
-- then we're done; otherwise we must search.
|
||||
|
||||
if Is_Greater_Key_Node (Key, N (Position)) then
|
||||
declare
|
||||
After : constant Count_Type := Ops.Next (Tree, Position);
|
||||
|
||||
begin
|
||||
if After = 0 then
|
||||
Insert_Post (Tree, Tree.Last, False, Node);
|
||||
Inserted := True;
|
||||
|
||||
elsif Is_Less_Key_Node (Key, N (After)) then
|
||||
if Ops.Right (N (Position)) = 0 then
|
||||
Insert_Post (Tree, Position, False, Node);
|
||||
else
|
||||
Insert_Post (Tree, After, True, Node);
|
||||
end if;
|
||||
|
||||
Inserted := True;
|
||||
|
||||
else
|
||||
Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- We know that Key is neither less than the hint nor greater
|
||||
-- than the hint, and that's the definition of equivalence.
|
||||
-- There's nothing else we need to do, since a search would just
|
||||
-- reach the same conclusion.
|
||||
|
||||
Node := Position;
|
||||
Inserted := False;
|
||||
end Generic_Conditional_Insert_With_Hint;
|
||||
|
||||
-------------------------
|
||||
-- Generic_Insert_Post --
|
||||
-------------------------
|
||||
|
||||
procedure Generic_Insert_Post
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
Before : Boolean;
|
||||
Z : out Count_Type)
|
||||
is
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
if Tree.Length >= Tree.Capacity then
|
||||
raise Capacity_Error with "not enough capacity to insert new item";
|
||||
end if;
|
||||
|
||||
if Tree.Busy > 0 then
|
||||
raise Program_Error with
|
||||
"attempt to tamper with cursors (container is busy)";
|
||||
end if;
|
||||
|
||||
Z := New_Node;
|
||||
pragma Assert (Z /= 0);
|
||||
|
||||
if Y = 0 then
|
||||
pragma Assert (Tree.Length = 0);
|
||||
pragma Assert (Tree.Root = 0);
|
||||
pragma Assert (Tree.First = 0);
|
||||
pragma Assert (Tree.Last = 0);
|
||||
|
||||
Tree.Root := Z;
|
||||
Tree.First := Z;
|
||||
Tree.Last := Z;
|
||||
|
||||
elsif Before then
|
||||
pragma Assert (Ops.Left (N (Y)) = 0);
|
||||
|
||||
Ops.Set_Left (N (Y), Z);
|
||||
|
||||
if Y = Tree.First then
|
||||
Tree.First := Z;
|
||||
end if;
|
||||
|
||||
else
|
||||
pragma Assert (Ops.Right (N (Y)) = 0);
|
||||
|
||||
Ops.Set_Right (N (Y), Z);
|
||||
|
||||
if Y = Tree.Last then
|
||||
Tree.Last := Z;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Ops.Set_Color (N (Z), Red);
|
||||
Ops.Set_Parent (N (Z), Y);
|
||||
Ops.Rebalance_For_Insert (Tree, Z);
|
||||
Tree.Length := Tree.Length + 1;
|
||||
end Generic_Insert_Post;
|
||||
|
||||
-----------------------
|
||||
-- Generic_Iteration --
|
||||
-----------------------
|
||||
|
||||
procedure Generic_Iteration
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type)
|
||||
is
|
||||
procedure Iterate (Index : Count_Type);
|
||||
|
||||
-------------
|
||||
-- Iterate --
|
||||
-------------
|
||||
|
||||
procedure Iterate (Index : Count_Type) is
|
||||
J : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
J := Index;
|
||||
while J /= 0 loop
|
||||
if Is_Less_Key_Node (Key, N (J)) then
|
||||
J := Ops.Left (N (J));
|
||||
elsif Is_Greater_Key_Node (Key, N (J)) then
|
||||
J := Ops.Right (N (J));
|
||||
else
|
||||
Iterate (Ops.Left (N (J)));
|
||||
Process (J);
|
||||
J := Ops.Right (N (J));
|
||||
end if;
|
||||
end loop;
|
||||
end Iterate;
|
||||
|
||||
-- Start of processing for Generic_Iteration
|
||||
|
||||
begin
|
||||
Iterate (Tree.Root);
|
||||
end Generic_Iteration;
|
||||
|
||||
-------------------------------
|
||||
-- Generic_Reverse_Iteration --
|
||||
-------------------------------
|
||||
|
||||
procedure Generic_Reverse_Iteration
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type)
|
||||
is
|
||||
procedure Iterate (Index : Count_Type);
|
||||
|
||||
-------------
|
||||
-- Iterate --
|
||||
-------------
|
||||
|
||||
procedure Iterate (Index : Count_Type) is
|
||||
J : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
J := Index;
|
||||
while J /= 0 loop
|
||||
if Is_Less_Key_Node (Key, N (J)) then
|
||||
J := Ops.Left (N (J));
|
||||
elsif Is_Greater_Key_Node (Key, N (J)) then
|
||||
J := Ops.Right (N (J));
|
||||
else
|
||||
Iterate (Ops.Right (N (J)));
|
||||
Process (J);
|
||||
J := Ops.Left (N (J));
|
||||
end if;
|
||||
end loop;
|
||||
end Iterate;
|
||||
|
||||
-- Start of processing for Generic_Reverse_Iteration
|
||||
|
||||
begin
|
||||
Iterate (Tree.Root);
|
||||
end Generic_Reverse_Iteration;
|
||||
|
||||
----------------------------------
|
||||
-- Generic_Unconditional_Insert --
|
||||
----------------------------------
|
||||
|
||||
procedure Generic_Unconditional_Insert
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type)
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
Before : Boolean;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
Before := False;
|
||||
|
||||
X := Tree.Root;
|
||||
while X /= 0 loop
|
||||
Y := X;
|
||||
Before := Is_Less_Key_Node (Key, N (X));
|
||||
X := (if Before then Ops.Left (N (X)) else Ops.Right (N (X)));
|
||||
end loop;
|
||||
|
||||
Insert_Post (Tree, Y, Before, Node);
|
||||
end Generic_Unconditional_Insert;
|
||||
|
||||
--------------------------------------------
|
||||
-- Generic_Unconditional_Insert_With_Hint --
|
||||
--------------------------------------------
|
||||
|
||||
procedure Generic_Unconditional_Insert_With_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Hint : Count_Type;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type)
|
||||
is
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
-- There are fewer constraints for an unconditional insertion
|
||||
-- than for a conditional insertion, since we allow duplicate
|
||||
-- keys. So instead of having to check (say) whether Key is
|
||||
-- (strictly) greater than the hint's previous neighbor, here we
|
||||
-- allow Key to be equal to or greater than the previous node.
|
||||
|
||||
-- There is the issue of what to do if Key is equivalent to the
|
||||
-- hint. Does the new node get inserted before or after the hint?
|
||||
-- We decide that it gets inserted after the hint, reasoning that
|
||||
-- this is consistent with behavior for non-hint insertion, which
|
||||
-- inserts a new node after existing nodes with equivalent keys.
|
||||
|
||||
-- First we check whether the hint is null, which is interpreted
|
||||
-- to mean that Key is large relative to existing nodes.
|
||||
-- Following our rule above, if Key is equal to or greater than
|
||||
-- the last node, then we insert the new node immediately after
|
||||
-- last. (We don't have an operation for testing whether a key is
|
||||
-- "equal to or greater than" a node, so we must say instead "not
|
||||
-- less than", which is equivalent.)
|
||||
|
||||
if Hint = 0 then -- largest
|
||||
if Tree.Last = 0 then
|
||||
Insert_Post (Tree, 0, False, Node);
|
||||
elsif Is_Less_Key_Node (Key, N (Tree.Last)) then
|
||||
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
|
||||
else
|
||||
Insert_Post (Tree, Tree.Last, False, Node);
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
pragma Assert (Tree.Length > 0);
|
||||
|
||||
-- We decide here whether to insert the new node prior to the
|
||||
-- hint. Key could be equivalent to the hint, so in theory we
|
||||
-- could write the following test as "not greater than" (same as
|
||||
-- "less than or equal to"). If Key were equivalent to the hint,
|
||||
-- that would mean that the new node gets inserted before an
|
||||
-- equivalent node. That wouldn't break any container invariants,
|
||||
-- but our rule above says that new nodes always get inserted
|
||||
-- after equivalent nodes. So here we test whether Key is both
|
||||
-- less than the hint and equal to or greater than the hint's
|
||||
-- previous neighbor, and if so insert it before the hint.
|
||||
|
||||
if Is_Less_Key_Node (Key, N (Hint)) then
|
||||
declare
|
||||
Before : constant Count_Type := Ops.Previous (Tree, Hint);
|
||||
begin
|
||||
if Before = 0 then
|
||||
Insert_Post (Tree, Hint, True, Node);
|
||||
elsif Is_Less_Key_Node (Key, N (Before)) then
|
||||
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
|
||||
elsif Ops.Right (N (Before)) = 0 then
|
||||
Insert_Post (Tree, Before, False, Node);
|
||||
else
|
||||
Insert_Post (Tree, Hint, True, Node);
|
||||
end if;
|
||||
end;
|
||||
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- We know that Key isn't less than the hint, so it must be equal
|
||||
-- or greater. So we just test whether Key is less than or equal
|
||||
-- to (same as "not greater than") the hint's next neighbor, and
|
||||
-- if so insert it after the hint.
|
||||
|
||||
declare
|
||||
After : constant Count_Type := Ops.Next (Tree, Hint);
|
||||
begin
|
||||
if After = 0 then
|
||||
Insert_Post (Tree, Hint, False, Node);
|
||||
elsif Is_Greater_Key_Node (Key, N (After)) then
|
||||
Unconditional_Insert_Sans_Hint (Tree, Key, Node);
|
||||
elsif Ops.Right (N (Hint)) = 0 then
|
||||
Insert_Post (Tree, Hint, False, Node);
|
||||
else
|
||||
Insert_Post (Tree, After, True, Node);
|
||||
end if;
|
||||
end;
|
||||
end Generic_Unconditional_Insert_With_Hint;
|
||||
|
||||
-----------------
|
||||
-- Upper_Bound --
|
||||
-----------------
|
||||
|
||||
function Upper_Bound
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type
|
||||
is
|
||||
Y : Count_Type;
|
||||
X : Count_Type;
|
||||
N : Nodes_Type renames Tree.Nodes;
|
||||
|
||||
begin
|
||||
Y := 0;
|
||||
|
||||
X := Tree.Root;
|
||||
while X /= 0 loop
|
||||
if Is_Less_Key_Node (Key, N (X)) then
|
||||
Y := X;
|
||||
X := Ops.Left (N (X));
|
||||
else
|
||||
X := Ops.Right (N (X));
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
return Y;
|
||||
end Upper_Bound;
|
||||
|
||||
end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
|
||||
193
gcc/ada/a-rbtgbk.ads
Normal file
193
gcc/ada/a-rbtgbk.ads
Normal file
@ -0,0 +1,193 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.CONTAINERS.RED_BLACK_TREES.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. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Tree_Type is used to implement ordered containers. This package declares
|
||||
-- the tree operations that depend on keys.
|
||||
|
||||
with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
|
||||
|
||||
generic
|
||||
with package Tree_Operations is new Generic_Bounded_Operations (<>);
|
||||
|
||||
use Tree_Operations.Tree_Types;
|
||||
|
||||
type Key_Type (<>) is limited private;
|
||||
|
||||
with function Is_Less_Key_Node
|
||||
(L : Key_Type;
|
||||
R : Node_Type) return Boolean;
|
||||
|
||||
with function Is_Greater_Key_Node
|
||||
(L : Key_Type;
|
||||
R : Node_Type) return Boolean;
|
||||
|
||||
package Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is
|
||||
pragma Pure;
|
||||
|
||||
generic
|
||||
with function New_Node return Count_Type;
|
||||
|
||||
procedure Generic_Insert_Post
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
Before : Boolean;
|
||||
Z : out Count_Type);
|
||||
-- Completes an insertion after the insertion position has been
|
||||
-- determined. On output Z contains the index of the newly inserted
|
||||
-- node, allocated using Allocate. If Tree is busy then
|
||||
-- Program_Error is raised. If Y is 0, then Tree must be empty.
|
||||
-- Otherwise Y denotes the insertion position, and Before specifies
|
||||
-- whether the new node is Y's left (True) or right (False) child.
|
||||
|
||||
generic
|
||||
with procedure Insert_Post
|
||||
(T : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
B : Boolean;
|
||||
Z : out Count_Type);
|
||||
|
||||
procedure Generic_Conditional_Insert
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type;
|
||||
Inserted : out Boolean);
|
||||
-- Inserts a new node in Tree, but only if the tree does not already
|
||||
-- contain Key. Generic_Conditional_Insert first searches for a key
|
||||
-- equivalent to Key in Tree. If an equivalent key is found, then on
|
||||
-- output Node designates the node with that key and Inserted is
|
||||
-- False; there is no allocation and Tree is not modified. Otherwise
|
||||
-- Node designates a new node allocated using Insert_Post, and
|
||||
-- Inserted is True.
|
||||
|
||||
generic
|
||||
with procedure Insert_Post
|
||||
(T : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
B : Boolean;
|
||||
Z : out Count_Type);
|
||||
|
||||
procedure Generic_Unconditional_Insert
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type);
|
||||
-- Inserts a new node in Tree. On output Node designates the new
|
||||
-- node, which is allocated using Insert_Post. The node is inserted
|
||||
-- immediately after already-existing equivalent keys.
|
||||
|
||||
generic
|
||||
with procedure Insert_Post
|
||||
(T : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
B : Boolean;
|
||||
Z : out Count_Type);
|
||||
|
||||
with procedure Unconditional_Insert_Sans_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type);
|
||||
|
||||
procedure Generic_Unconditional_Insert_With_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Hint : Count_Type;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type);
|
||||
-- Inserts a new node in Tree near position Hint, to avoid having to
|
||||
-- search from the root for the insertion position. If Hint is 0
|
||||
-- then Generic_Unconditional_Insert_With_Hint attempts to insert
|
||||
-- the new node after Tree.Last. If Hint is non-zero then if Key is
|
||||
-- less than Hint, it attempts to insert the new node immediately
|
||||
-- prior to Hint. Otherwise it attempts to insert the node
|
||||
-- immediately following Hint. We say "attempts" above to emphasize
|
||||
-- that insertions always preserve invariants with respect to key
|
||||
-- order, even when there's a hint. So if Key can't be inserted
|
||||
-- immediately near Hint, then the new node is inserted in the
|
||||
-- normal way, by searching for the correct position starting from
|
||||
-- the root.
|
||||
|
||||
generic
|
||||
with procedure Insert_Post
|
||||
(T : in out Tree_Type'Class;
|
||||
Y : Count_Type;
|
||||
B : Boolean;
|
||||
Z : out Count_Type);
|
||||
|
||||
with procedure Conditional_Insert_Sans_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type;
|
||||
Inserted : out Boolean);
|
||||
|
||||
procedure Generic_Conditional_Insert_With_Hint
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Position : Count_Type; -- the hint
|
||||
Key : Key_Type;
|
||||
Node : out Count_Type;
|
||||
Inserted : out Boolean);
|
||||
-- Inserts a new node in Tree if the tree does not already contain
|
||||
-- Key, using Position as a hint about where to insert the new node.
|
||||
-- See Generic_Unconditional_Insert_With_Hint for more details about
|
||||
-- hint semantics.
|
||||
|
||||
function Find
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type;
|
||||
-- Searches Tree for the smallest node equivalent to Key
|
||||
|
||||
function Ceiling
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type;
|
||||
-- Searches Tree for the smallest node equal to or greater than Key
|
||||
|
||||
function Floor
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type;
|
||||
-- Searches Tree for the largest node less than or equal to Key
|
||||
|
||||
function Upper_Bound
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type) return Count_Type;
|
||||
-- Searches Tree for the smallest node greater than Key
|
||||
|
||||
generic
|
||||
with procedure Process (Index : Count_Type);
|
||||
procedure Generic_Iteration
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type);
|
||||
-- Calls Process for each node in Tree equivalent to Key, in order
|
||||
-- from earliest in range to latest.
|
||||
|
||||
generic
|
||||
with procedure Process (Index : Count_Type);
|
||||
procedure Generic_Reverse_Iteration
|
||||
(Tree : Tree_Type'Class;
|
||||
Key : Key_Type);
|
||||
-- Calls Process for each node in Tree equivalent to Key, but in
|
||||
-- order from largest in range to earliest.
|
||||
|
||||
end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys;
|
||||
1118
gcc/ada/a-rbtgbo.adb
Normal file
1118
gcc/ada/a-rbtgbo.adb
Normal file
File diff suppressed because it is too large
Load Diff
155
gcc/ada/a-rbtgbo.ads
Normal file
155
gcc/ada/a-rbtgbo.ads
Normal file
@ -0,0 +1,155 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- ADA.CONTAINERS.RED_BLACK_TREES.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. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Tree_Type is used to implement the ordered containers. This package
|
||||
-- declares the tree operations that do not depend on keys.
|
||||
|
||||
with Ada.Streams; use Ada.Streams;
|
||||
|
||||
generic
|
||||
with package Tree_Types is new Generic_Bounded_Tree_Types (<>);
|
||||
use Tree_Types;
|
||||
|
||||
with function Parent (Node : Node_Type) return Count_Type is <>;
|
||||
|
||||
with procedure Set_Parent
|
||||
(Node : in out Node_Type;
|
||||
Parent : Count_Type) is <>;
|
||||
|
||||
with function Left (Node : Node_Type) return Count_Type is <>;
|
||||
|
||||
with procedure Set_Left
|
||||
(Node : in out Node_Type;
|
||||
Left : Count_Type) is <>;
|
||||
|
||||
with function Right (Node : Node_Type) return Count_Type is <>;
|
||||
|
||||
with procedure Set_Right
|
||||
(Node : in out Node_Type;
|
||||
Right : Count_Type) is <>;
|
||||
|
||||
with function Color (Node : Node_Type) return Color_Type is <>;
|
||||
|
||||
with procedure Set_Color
|
||||
(Node : in out Node_Type;
|
||||
Color : Color_Type) is <>;
|
||||
|
||||
package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
|
||||
pragma Pure;
|
||||
|
||||
function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type;
|
||||
-- Returns the smallest-valued node of the subtree rooted at Node
|
||||
|
||||
function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type;
|
||||
-- Returns the largest-valued node of the subtree rooted at Node
|
||||
|
||||
function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean;
|
||||
-- Inspects Node to determine (to the extent possible) whether
|
||||
-- the node is valid; used to detect if the node is dangling.
|
||||
|
||||
function Next
|
||||
(Tree : Tree_Type'Class;
|
||||
Node : Count_Type) return Count_Type;
|
||||
-- Returns the smallest node greater than Node
|
||||
|
||||
function Previous
|
||||
(Tree : Tree_Type'Class;
|
||||
Node : Count_Type) return Count_Type;
|
||||
-- Returns the largest node less than Node
|
||||
|
||||
generic
|
||||
with function Is_Equal (L, R : Node_Type) return Boolean;
|
||||
function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean;
|
||||
-- Uses Is_Equal to perform a node-by-node comparison of the
|
||||
-- Left and Right trees; processing stops as soon as the first
|
||||
-- non-equal node is found.
|
||||
|
||||
procedure Delete_Node_Sans_Free
|
||||
(Tree : in out Tree_Type'Class; Node : Count_Type);
|
||||
-- Removes Node from Tree without deallocating the node. If Tree
|
||||
-- is busy then Program_Error is raised.
|
||||
|
||||
procedure Clear_Tree (Tree : in out Tree_Type'Class);
|
||||
-- Clears Tree by deallocating all of its nodes. If Tree is busy then
|
||||
-- Program_Error is raised.
|
||||
|
||||
generic
|
||||
with procedure Process (Node : Count_Type) is <>;
|
||||
procedure Generic_Iteration (Tree : Tree_Type'Class);
|
||||
-- Calls Process for each node in Tree, in order from smallest-valued
|
||||
-- node to largest-valued node.
|
||||
|
||||
generic
|
||||
with procedure Process (Node : Count_Type) is <>;
|
||||
procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class);
|
||||
-- Calls Process for each node in Tree, in order from largest-valued
|
||||
-- node to smallest-valued node.
|
||||
|
||||
generic
|
||||
with procedure Write_Node
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Node : Node_Type);
|
||||
procedure Generic_Write
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Tree : Tree_Type'Class);
|
||||
-- Used to implement stream attribute T'Write. Generic_Write
|
||||
-- first writes the number of nodes into Stream, then calls
|
||||
-- Write_Node for each node in Tree.
|
||||
|
||||
generic
|
||||
with procedure Allocate
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Node : out Count_Type);
|
||||
procedure Generic_Read
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Tree : in out Tree_Type'Class);
|
||||
-- Used to implement stream attribute T'Read. Generic_Read
|
||||
-- first clears Tree. It then reads the number of nodes out of
|
||||
-- Stream, and calls Read_Node for each node in Stream.
|
||||
|
||||
procedure Rebalance_For_Insert
|
||||
(Tree : in out Tree_Type'Class;
|
||||
Node : Count_Type);
|
||||
-- This rebalances Tree to complete the insertion of Node (which
|
||||
-- must already be linked in at its proper insertion position).
|
||||
|
||||
generic
|
||||
with procedure Set_Element (Node : in out Node_Type);
|
||||
procedure Generic_Allocate
|
||||
(Tree : in out Tree_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 (Tree : in out Tree_Type'Class; X : Count_Type);
|
||||
-- Return a node back to the free store, from where it had
|
||||
-- been previously claimed via Generic_Allocate.
|
||||
|
||||
end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations;
|
||||
@ -1099,11 +1099,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
|
||||
either case. */
|
||||
attr->file_length = statbuf.st_size; /* all systems */
|
||||
|
||||
#ifndef __MINGW32__
|
||||
/* on Windows requires extra system call, see comment in
|
||||
__gnat_file_exists_attr */
|
||||
attr->exists = !ret;
|
||||
#endif
|
||||
|
||||
#if !defined (_WIN32) || defined (RTX)
|
||||
/* on Windows requires extra system call, see __gnat_is_readable_file_attr */
|
||||
@ -1343,7 +1339,8 @@ win32_filetime (HANDLE h)
|
||||
}
|
||||
|
||||
/* As above but starting from a FILETIME. */
|
||||
static void f2t (const FILETIME *ft, time_t *t)
|
||||
static void
|
||||
f2t (const FILETIME *ft, time_t *t)
|
||||
{
|
||||
union
|
||||
{
|
||||
@ -1363,18 +1360,14 @@ __gnat_file_time_name_attr (char* name, struct file_attributes* attr)
|
||||
{
|
||||
if (attr->timestamp == (OS_Time)-2) {
|
||||
#if defined (_WIN32) && !defined (RTX)
|
||||
BOOL res;
|
||||
WIN32_FILE_ATTRIBUTE_DATA fad;
|
||||
time_t ret = -1;
|
||||
TCHAR wname[GNAT_MAX_PATH_LEN];
|
||||
S2WSC (wname, name, GNAT_MAX_PATH_LEN);
|
||||
|
||||
HANDLE h = CreateFile
|
||||
(wname, GENERIC_READ, FILE_SHARE_READ, 0,
|
||||
OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, 0);
|
||||
|
||||
if (h != INVALID_HANDLE_VALUE) {
|
||||
ret = win32_filetime (h);
|
||||
CloseHandle (h);
|
||||
}
|
||||
if (res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad))
|
||||
f2t (&fad.ftLastWriteTime, &ret);
|
||||
attr->timestamp = (OS_Time) ret;
|
||||
#else
|
||||
__gnat_stat_to_attr (-1, name, attr);
|
||||
@ -1713,17 +1706,17 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
|
||||
|
||||
if (res == FALSE)
|
||||
switch (GetLastError()) {
|
||||
case ERROR_ACCESS_DENIED:
|
||||
case ERROR_SHARING_VIOLATION:
|
||||
case ERROR_LOCK_VIOLATION:
|
||||
case ERROR_SHARING_BUFFER_EXCEEDED:
|
||||
return EACCES;
|
||||
case ERROR_BUFFER_OVERFLOW:
|
||||
return ENAMETOOLONG;
|
||||
case ERROR_NOT_ENOUGH_MEMORY:
|
||||
return ENOMEM;
|
||||
default:
|
||||
return ENOENT;
|
||||
case ERROR_ACCESS_DENIED:
|
||||
case ERROR_SHARING_VIOLATION:
|
||||
case ERROR_LOCK_VIOLATION:
|
||||
case ERROR_SHARING_BUFFER_EXCEEDED:
|
||||
return EACCES;
|
||||
case ERROR_BUFFER_OVERFLOW:
|
||||
return ENAMETOOLONG;
|
||||
case ERROR_NOT_ENOUGH_MEMORY:
|
||||
return ENOMEM;
|
||||
default:
|
||||
return ENOENT;
|
||||
}
|
||||
|
||||
f2t (&fad.ftCreationTime, &statbuf->st_ctime);
|
||||
@ -1758,16 +1751,7 @@ int
|
||||
__gnat_file_exists_attr (char* name, struct file_attributes* attr)
|
||||
{
|
||||
if (attr->exists == ATTR_UNSET) {
|
||||
#ifdef __MINGW32__
|
||||
/* On Windows do not use __gnat_stat() because of a bug in Microsoft
|
||||
_stat() routine. When the system time-zone is set with a negative
|
||||
offset the _stat() routine fails on specific files like CON: */
|
||||
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
|
||||
S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
|
||||
attr->exists = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES;
|
||||
#else
|
||||
__gnat_stat_to_attr (-1, name, attr);
|
||||
#endif
|
||||
}
|
||||
|
||||
return attr->exists;
|
||||
|
||||
@ -41,6 +41,7 @@ with Sem_Aux; use Sem_Aux;
|
||||
with Sem_Cat; use Sem_Cat;
|
||||
with Sem_Ch3; use Sem_Ch3;
|
||||
with Sem_Ch8; use Sem_Ch8;
|
||||
with Sem_Ch12; use Sem_Ch12;
|
||||
with Sem_Dist; use Sem_Dist;
|
||||
with Sem_Eval; use Sem_Eval;
|
||||
with Sem_Util; use Sem_Util;
|
||||
@ -225,9 +226,7 @@ package body Exp_Dist is
|
||||
-- In either case, this means stubs cannot contain a default-initialized
|
||||
-- object declaration of such type.
|
||||
|
||||
procedure Add_Calling_Stubs_To_Declarations
|
||||
(Pkg_Spec : Node_Id;
|
||||
Decls : List_Id);
|
||||
procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id);
|
||||
-- Add calling stubs to the declarative part
|
||||
|
||||
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
|
||||
@ -915,27 +914,145 @@ package body Exp_Dist is
|
||||
-- since this require separate mechanisms ('Input is a function while
|
||||
-- 'Read is a procedure).
|
||||
|
||||
generic
|
||||
with procedure Process_Subprogram_Declaration (Decl : Node_Id);
|
||||
-- Generate calling or receiving stub for this subprogram declaration
|
||||
|
||||
procedure Build_Package_Stubs (Pkg_Spec : Node_Id);
|
||||
-- Recursively visit the given RCI Package_Specification, calling
|
||||
-- Process_Subprogram_Declaration for each remote subprogram.
|
||||
|
||||
-------------------------
|
||||
-- Build_Package_Stubs --
|
||||
-------------------------
|
||||
|
||||
procedure Build_Package_Stubs (Pkg_Spec : Node_Id) is
|
||||
Decls : constant List_Id := Visible_Declarations (Pkg_Spec);
|
||||
Decl : Node_Id;
|
||||
|
||||
procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id);
|
||||
-- Recurse for the given nested package declaration
|
||||
|
||||
-----------------------
|
||||
-- Visit_Nested_Spec --
|
||||
-----------------------
|
||||
|
||||
procedure Visit_Nested_Pkg (Nested_Pkg_Decl : Node_Id) is
|
||||
Nested_Pkg_Spec : constant Node_Id := Specification (Nested_Pkg_Decl);
|
||||
begin
|
||||
Push_Scope (Scope_Of_Spec (Nested_Pkg_Spec));
|
||||
Build_Package_Stubs (Nested_Pkg_Spec);
|
||||
Pop_Scope;
|
||||
end Visit_Nested_Pkg;
|
||||
|
||||
-- Start of processing for Build_Package_Stubs
|
||||
|
||||
begin
|
||||
Decl := First (Decls);
|
||||
while Present (Decl) loop
|
||||
case Nkind (Decl) is
|
||||
when N_Subprogram_Declaration =>
|
||||
|
||||
-- Note: we test Comes_From_Source on Spec, not Decl, because
|
||||
-- in the case of a subprogram instance, only the specification
|
||||
-- (not the declaration) is marked as coming from source.
|
||||
|
||||
if Comes_From_Source (Specification (Decl)) then
|
||||
Process_Subprogram_Declaration (Decl);
|
||||
end if;
|
||||
|
||||
when N_Package_Declaration =>
|
||||
|
||||
-- Case of a nested package or package instantiation coming
|
||||
-- from source. Note that the anonymous wrapper package for
|
||||
-- subprogram instances is not flagged Is_Generic_Instance at
|
||||
-- this point, so there is a distinct circuit to handle them
|
||||
-- (see case N_Subprogram_Instantiation below).
|
||||
|
||||
declare
|
||||
Pkg_Ent : constant Entity_Id :=
|
||||
Defining_Unit_Name (Specification (Decl));
|
||||
begin
|
||||
if Comes_From_Source (Decl)
|
||||
or else
|
||||
(Is_Generic_Instance (Pkg_Ent)
|
||||
and then Comes_From_Source
|
||||
(Get_Package_Instantiation_Node (Pkg_Ent)))
|
||||
then
|
||||
Visit_Nested_Pkg (Decl);
|
||||
end if;
|
||||
end;
|
||||
|
||||
when N_Subprogram_Instantiation =>
|
||||
|
||||
-- The subprogram declaration for an instance of a generic
|
||||
-- subprogram is wrapped in a package that does not come from
|
||||
-- source, so we need to explicitly traverse it here.
|
||||
|
||||
if Comes_From_Source (Decl) then
|
||||
Visit_Nested_Pkg (Instance_Spec (Decl));
|
||||
end if;
|
||||
|
||||
when others =>
|
||||
null;
|
||||
end case;
|
||||
Next (Decl);
|
||||
end loop;
|
||||
end Build_Package_Stubs;
|
||||
|
||||
---------------------------------------
|
||||
-- Add_Calling_Stubs_To_Declarations --
|
||||
---------------------------------------
|
||||
|
||||
procedure Add_Calling_Stubs_To_Declarations
|
||||
(Pkg_Spec : Node_Id;
|
||||
Decls : List_Id)
|
||||
is
|
||||
procedure Add_Calling_Stubs_To_Declarations (Pkg_Spec : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
|
||||
|
||||
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
|
||||
-- Subprogram id 0 is reserved for calls received from
|
||||
-- remote access-to-subprogram dereferences.
|
||||
|
||||
Current_Declaration : Node_Id;
|
||||
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
|
||||
RCI_Instantiation : Node_Id;
|
||||
Subp_Stubs : Node_Id;
|
||||
Subp_Str : String_Id;
|
||||
|
||||
pragma Warnings (Off, Subp_Str);
|
||||
procedure Visit_Subprogram (Decl : Node_Id);
|
||||
-- Generate calling stub for one remote subprogram
|
||||
|
||||
----------------------
|
||||
-- Visit_Subprogram --
|
||||
----------------------
|
||||
|
||||
procedure Visit_Subprogram (Decl : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (Decl);
|
||||
Spec : constant Node_Id := Specification (Decl);
|
||||
Subp_Stubs : Node_Id;
|
||||
Subp_Str : String_Id;
|
||||
pragma Warnings (Off, Subp_Str);
|
||||
|
||||
begin
|
||||
Assign_Subprogram_Identifier
|
||||
(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)));
|
||||
|
||||
Append_To (List_Containing (Decl), Subp_Stubs);
|
||||
Analyze (Subp_Stubs);
|
||||
|
||||
Current_Subprogram_Number := Current_Subprogram_Number + 1;
|
||||
end Visit_Subprogram;
|
||||
|
||||
procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
|
||||
|
||||
-- Start of processing for Add_Calling_Stubs_To_Declarations
|
||||
|
||||
begin
|
||||
Push_Scope (Scope_Of_Spec (Pkg_Spec));
|
||||
|
||||
-- The first thing added is an instantiation of the generic package
|
||||
-- System.Partition_Interface.RCI_Locator with the name of this remote
|
||||
-- package. This will act as an interface with the name server to
|
||||
@ -945,51 +1062,21 @@ package body Exp_Dist is
|
||||
RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
|
||||
RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
|
||||
|
||||
Append_To (Decls, RCI_Instantiation);
|
||||
Append_To (Visible_Declarations (Pkg_Spec), RCI_Instantiation);
|
||||
Analyze (RCI_Instantiation);
|
||||
|
||||
-- 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 do use the same
|
||||
-- to each subprograms. The receiving stubs processing uses the same
|
||||
-- mechanism and will thus assign the same Id and do the correct
|
||||
-- dispatching.
|
||||
|
||||
Overload_Counter_Table.Reset;
|
||||
PolyORB_Support.Reserve_NamingContext_Methods;
|
||||
|
||||
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
|
||||
while Present (Current_Declaration) loop
|
||||
if Nkind (Current_Declaration) = N_Subprogram_Declaration
|
||||
and then Comes_From_Source (Current_Declaration)
|
||||
then
|
||||
Assign_Subprogram_Identifier
|
||||
(Defining_Unit_Name (Specification (Current_Declaration)),
|
||||
Current_Subprogram_Number,
|
||||
Subp_Str);
|
||||
Visit_Spec (Pkg_Spec);
|
||||
|
||||
Subp_Stubs :=
|
||||
Build_Subprogram_Calling_Stubs (
|
||||
Vis_Decl => Current_Declaration,
|
||||
Subp_Id =>
|
||||
Build_Subprogram_Id (Loc,
|
||||
Defining_Unit_Name (Specification (Current_Declaration))),
|
||||
Asynchronous =>
|
||||
Nkind (Specification (Current_Declaration)) =
|
||||
N_Procedure_Specification
|
||||
and then
|
||||
Is_Asynchronous (Defining_Unit_Name (Specification
|
||||
(Current_Declaration))));
|
||||
|
||||
Append_To (Decls, Subp_Stubs);
|
||||
Analyze (Subp_Stubs);
|
||||
|
||||
Current_Subprogram_Number := Current_Subprogram_Number + 1;
|
||||
end if;
|
||||
|
||||
-- Need to handle the case of nested packages???
|
||||
|
||||
Next (Current_Declaration);
|
||||
end loop;
|
||||
Pop_Scope;
|
||||
end Add_Calling_Stubs_To_Declarations;
|
||||
|
||||
-----------------------------
|
||||
@ -2819,12 +2906,8 @@ package body Exp_Dist is
|
||||
|
||||
procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
|
||||
Spec : constant Node_Id := Specification (Unit_Node);
|
||||
Decls : constant List_Id := Visible_Declarations (Spec);
|
||||
begin
|
||||
Push_Scope (Scope_Of_Spec (Spec));
|
||||
Add_Calling_Stubs_To_Declarations
|
||||
(Specification (Unit_Node), Decls);
|
||||
Pop_Scope;
|
||||
Add_Calling_Stubs_To_Declarations (Spec);
|
||||
end Expand_Calling_Stubs_Bodies;
|
||||
|
||||
-----------------------------------
|
||||
@ -3685,6 +3768,7 @@ package body Exp_Dist is
|
||||
Pkg_RPC_Receiver_Body : Node_Id;
|
||||
-- A Pkg_RPC_Receiver is built to decode the request
|
||||
|
||||
Lookup_RAS : Node_Id;
|
||||
Lookup_RAS_Info : constant Entity_Id := Make_Temporary (Loc, 'R');
|
||||
-- A remote subprogram is created to allow peers to look up RAS
|
||||
-- information using subprogram ids.
|
||||
@ -3693,9 +3777,8 @@ package body Exp_Dist is
|
||||
Subp_Index : Entity_Id;
|
||||
-- Subprogram_Id as read from the incoming stream
|
||||
|
||||
Current_Declaration : Node_Id;
|
||||
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
|
||||
Current_Stubs : Node_Id;
|
||||
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
|
||||
Current_Stubs : Node_Id;
|
||||
|
||||
Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
|
||||
Subp_Info_List : constant List_Id := New_List;
|
||||
@ -3713,6 +3796,9 @@ package body Exp_Dist is
|
||||
-- associating Subprogram_Number with the subprogram declared
|
||||
-- by Declaration, for which we have receiving stubs in Stubs.
|
||||
|
||||
procedure Visit_Subprogram (Decl : Node_Id);
|
||||
-- Generate receiving stub for one remote subprogram
|
||||
|
||||
---------------------
|
||||
-- Append_Stubs_To --
|
||||
---------------------
|
||||
@ -3736,6 +3822,76 @@ package body Exp_Dist is
|
||||
New_Occurrence_Of (Request_Parameter, Loc))))));
|
||||
end Append_Stubs_To;
|
||||
|
||||
----------------------
|
||||
-- Visit_Subprogram --
|
||||
----------------------
|
||||
|
||||
procedure Visit_Subprogram (Decl : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (Decl);
|
||||
Spec : constant Node_Id := Specification (Decl);
|
||||
Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
|
||||
|
||||
Subp_Val : String_Id;
|
||||
pragma Warnings (Off, Subp_Val);
|
||||
|
||||
begin
|
||||
-- Build receiving stub
|
||||
|
||||
Current_Stubs :=
|
||||
Build_Subprogram_Receiving_Stubs
|
||||
(Vis_Decl => Decl,
|
||||
Asynchronous =>
|
||||
Nkind (Spec) = N_Procedure_Specification
|
||||
and then Is_Asynchronous (Subp_Def));
|
||||
|
||||
Append_To (Decls, Current_Stubs);
|
||||
Analyze (Current_Stubs);
|
||||
|
||||
-- Build RAS proxy
|
||||
|
||||
Add_RAS_Proxy_And_Analyze (Decls,
|
||||
Vis_Decl => Decl,
|
||||
All_Calls_Remote_E => All_Calls_Remote_E,
|
||||
Proxy_Object_Addr => Proxy_Object_Addr);
|
||||
|
||||
-- Compute distribution identifier
|
||||
|
||||
Assign_Subprogram_Identifier
|
||||
(Subp_Def, Current_Subp_Number, Subp_Val);
|
||||
|
||||
pragma Assert (Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
|
||||
|
||||
-- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
|
||||
-- table for this receiver. This aggregate must be kept consistent
|
||||
-- with the declaration of RCI_Subp_Info in
|
||||
-- System.Partition_Interface.
|
||||
|
||||
Append_To (Subp_Info_List,
|
||||
Make_Component_Association (Loc,
|
||||
Choices => New_List (
|
||||
Make_Integer_Literal (Loc, Current_Subp_Number)),
|
||||
|
||||
Expression =>
|
||||
Make_Aggregate (Loc,
|
||||
Component_Associations => New_List (
|
||||
|
||||
-- Addr =>
|
||||
|
||||
Make_Component_Association (Loc,
|
||||
Choices =>
|
||||
New_List (Make_Identifier (Loc, Name_Addr)),
|
||||
Expression =>
|
||||
New_Occurrence_Of (Proxy_Object_Addr, Loc))))));
|
||||
|
||||
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
|
||||
Stubs => Current_Stubs,
|
||||
Subprogram_Number => Current_Subp_Number);
|
||||
|
||||
Current_Subp_Number := Current_Subp_Number + 1;
|
||||
end Visit_Subprogram;
|
||||
|
||||
procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
|
||||
|
||||
-- Start of processing for Add_Receiving_Stubs_To_Declarations
|
||||
|
||||
begin
|
||||
@ -3800,7 +3956,7 @@ package body Exp_Dist is
|
||||
|
||||
-- Build a subprogram for RAS information lookups
|
||||
|
||||
Current_Declaration :=
|
||||
Lookup_RAS :=
|
||||
Make_Subprogram_Declaration (Loc,
|
||||
Specification =>
|
||||
Make_Function_Specification (Loc,
|
||||
@ -3816,19 +3972,17 @@ package body Exp_Dist is
|
||||
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
|
||||
Result_Definition =>
|
||||
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
|
||||
|
||||
Append_To (Decls, Current_Declaration);
|
||||
Analyze (Current_Declaration);
|
||||
Append_To (Decls, Lookup_RAS);
|
||||
Analyze (Lookup_RAS);
|
||||
|
||||
Current_Stubs := Build_Subprogram_Receiving_Stubs
|
||||
(Vis_Decl => Current_Declaration,
|
||||
(Vis_Decl => Lookup_RAS,
|
||||
Asynchronous => False);
|
||||
Append_To (Decls, Current_Stubs);
|
||||
Analyze (Current_Stubs);
|
||||
|
||||
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
|
||||
Stubs =>
|
||||
Current_Stubs,
|
||||
Stubs => Current_Stubs,
|
||||
Subprogram_Number => 1);
|
||||
|
||||
-- For each subprogram, the receiving stub will be built and a
|
||||
@ -3841,87 +3995,7 @@ package body Exp_Dist is
|
||||
|
||||
Overload_Counter_Table.Reset;
|
||||
|
||||
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
|
||||
while Present (Current_Declaration) loop
|
||||
if Nkind (Current_Declaration) = N_Subprogram_Declaration
|
||||
and then Comes_From_Source (Current_Declaration)
|
||||
then
|
||||
declare
|
||||
Loc : constant Source_Ptr := Sloc (Current_Declaration);
|
||||
-- While specifically processing Current_Declaration, use
|
||||
-- its Sloc as the location of all generated nodes.
|
||||
|
||||
Subp_Def : constant Entity_Id :=
|
||||
Defining_Unit_Name
|
||||
(Specification (Current_Declaration));
|
||||
|
||||
Subp_Val : String_Id;
|
||||
pragma Warnings (Off, Subp_Val);
|
||||
|
||||
begin
|
||||
-- Build receiving stub
|
||||
|
||||
Current_Stubs :=
|
||||
Build_Subprogram_Receiving_Stubs
|
||||
(Vis_Decl => Current_Declaration,
|
||||
Asynchronous =>
|
||||
Nkind (Specification (Current_Declaration)) =
|
||||
N_Procedure_Specification
|
||||
and then Is_Asynchronous (Subp_Def));
|
||||
|
||||
Append_To (Decls, Current_Stubs);
|
||||
Analyze (Current_Stubs);
|
||||
|
||||
-- Build RAS proxy
|
||||
|
||||
Add_RAS_Proxy_And_Analyze (Decls,
|
||||
Vis_Decl => Current_Declaration,
|
||||
All_Calls_Remote_E => All_Calls_Remote_E,
|
||||
Proxy_Object_Addr => Proxy_Object_Addr);
|
||||
|
||||
-- Compute distribution identifier
|
||||
|
||||
Assign_Subprogram_Identifier
|
||||
(Subp_Def,
|
||||
Current_Subprogram_Number,
|
||||
Subp_Val);
|
||||
|
||||
pragma Assert
|
||||
(Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
|
||||
|
||||
-- Add subprogram descriptor (RCI_Subp_Info) to the
|
||||
-- subprograms table for this receiver. The aggregate
|
||||
-- below must be kept consistent with the declaration
|
||||
-- of type RCI_Subp_Info in System.Partition_Interface.
|
||||
|
||||
Append_To (Subp_Info_List,
|
||||
Make_Component_Association (Loc,
|
||||
Choices => New_List (
|
||||
Make_Integer_Literal (Loc,
|
||||
Current_Subprogram_Number)),
|
||||
|
||||
Expression =>
|
||||
Make_Aggregate (Loc,
|
||||
Component_Associations => New_List (
|
||||
Make_Component_Association (Loc,
|
||||
Choices => New_List (
|
||||
Make_Identifier (Loc, Name_Addr)),
|
||||
Expression =>
|
||||
New_Occurrence_Of (
|
||||
Proxy_Object_Addr, Loc))))));
|
||||
|
||||
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
|
||||
Stubs => Current_Stubs,
|
||||
Subprogram_Number => Current_Subprogram_Number);
|
||||
end;
|
||||
|
||||
Current_Subprogram_Number := Current_Subprogram_Number + 1;
|
||||
end if;
|
||||
|
||||
-- Need to handle case of a nested package???
|
||||
|
||||
Next (Current_Declaration);
|
||||
end loop;
|
||||
Visit_Spec (Pkg_Spec);
|
||||
|
||||
-- If we receive an invalid Subprogram_Id, it is best to do nothing
|
||||
-- rather than raising an exception since we do not want someone
|
||||
@ -6654,13 +6728,10 @@ package body Exp_Dist is
|
||||
Dispatch_On_Address : constant List_Id := New_List;
|
||||
Dispatch_On_Name : constant List_Id := New_List;
|
||||
|
||||
Current_Declaration : Node_Id;
|
||||
Current_Stubs : Node_Id;
|
||||
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
|
||||
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
|
||||
|
||||
Subp_Info_Array : constant Entity_Id := Make_Temporary (Loc, 'I');
|
||||
|
||||
Subp_Info_List : constant List_Id := New_List;
|
||||
Subp_Info_List : constant List_Id := New_List;
|
||||
|
||||
Register_Pkg_Actuals : constant List_Id := New_List;
|
||||
|
||||
@ -6681,6 +6752,9 @@ package body Exp_Dist is
|
||||
-- object, used in the context of calls through remote
|
||||
-- access-to-subprogram types.
|
||||
|
||||
procedure Visit_Subprogram (Decl : Node_Id);
|
||||
-- Generate receiving stub for one remote subprogram
|
||||
|
||||
---------------------
|
||||
-- Append_Stubs_To --
|
||||
---------------------
|
||||
@ -6744,6 +6818,110 @@ package body Exp_Dist is
|
||||
Make_Integer_Literal (Loc, Subp_Number)))));
|
||||
end Append_Stubs_To;
|
||||
|
||||
----------------------
|
||||
-- Visit_Subprogram --
|
||||
----------------------
|
||||
|
||||
procedure Visit_Subprogram (Decl : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (Decl);
|
||||
Spec : constant Node_Id := Specification (Decl);
|
||||
Subp_Def : constant Entity_Id := Defining_Unit_Name (Spec);
|
||||
|
||||
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));
|
||||
|
||||
Current_Stubs : Node_Id;
|
||||
Proxy_Obj_Addr : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Build receiving stub
|
||||
|
||||
Current_Stubs :=
|
||||
Build_Subprogram_Receiving_Stubs
|
||||
(Vis_Decl => Decl,
|
||||
Asynchronous =>
|
||||
Nkind (Spec) = N_Procedure_Specification
|
||||
and then Is_Asynchronous (Subp_Def));
|
||||
|
||||
Append_To (Decls, Current_Stubs);
|
||||
Analyze (Current_Stubs);
|
||||
|
||||
-- Build RAS proxy
|
||||
|
||||
Add_RAS_Proxy_And_Analyze (Decls,
|
||||
Vis_Decl => Decl,
|
||||
All_Calls_Remote_E => All_Calls_Remote_E,
|
||||
Proxy_Object_Addr => Proxy_Obj_Addr);
|
||||
|
||||
-- Compute distribution identifier
|
||||
|
||||
Assign_Subprogram_Identifier
|
||||
(Subp_Def, Current_Subp_Number, Subp_Val);
|
||||
|
||||
pragma Assert
|
||||
(Current_Subp_Number = Get_Subprogram_Id (Subp_Def));
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Subp_Dist_Name,
|
||||
Constant_Present => True,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_String_Literal (Loc, Subp_Val)));
|
||||
Analyze (Last (Decls));
|
||||
|
||||
-- Add subprogram descriptor (RCI_Subp_Info) to the subprograms
|
||||
-- table for this receiver. The aggregate below must be kept
|
||||
-- consistent with the declaration of RCI_Subp_Info in
|
||||
-- System.Partition_Interface.
|
||||
|
||||
Append_To (Subp_Info_List,
|
||||
Make_Component_Association (Loc,
|
||||
Choices =>
|
||||
New_List (Make_Integer_Literal (Loc, Current_Subp_Number)),
|
||||
|
||||
Expression =>
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => New_List (
|
||||
|
||||
-- Name =>
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Subp_Dist_Name, Loc),
|
||||
Attribute_Name => Name_Address),
|
||||
|
||||
-- Name_Length =>
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Subp_Dist_Name, Loc),
|
||||
Attribute_Name => Name_Length),
|
||||
|
||||
-- Addr =>
|
||||
|
||||
New_Occurrence_Of (Proxy_Obj_Addr, Loc)))));
|
||||
|
||||
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
|
||||
Declaration => Decl,
|
||||
Stubs => Current_Stubs,
|
||||
Subp_Number => Current_Subp_Number,
|
||||
Subp_Dist_Name => Subp_Dist_Name,
|
||||
Subp_Proxy_Addr => Proxy_Obj_Addr);
|
||||
|
||||
Current_Subp_Number := Current_Subp_Number + 1;
|
||||
end Visit_Subprogram;
|
||||
|
||||
procedure Visit_Spec is new Build_Package_Stubs (Visit_Subprogram);
|
||||
|
||||
-- Start of processing for Add_Receiving_Stubs_To_Declarations
|
||||
|
||||
begin
|
||||
@ -6804,113 +6982,7 @@ package body Exp_Dist is
|
||||
Overload_Counter_Table.Reset;
|
||||
Reserve_NamingContext_Methods;
|
||||
|
||||
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
|
||||
while Present (Current_Declaration) loop
|
||||
if Nkind (Current_Declaration) = N_Subprogram_Declaration
|
||||
and then Comes_From_Source (Current_Declaration)
|
||||
then
|
||||
declare
|
||||
Loc : constant Source_Ptr := Sloc (Current_Declaration);
|
||||
-- While specifically processing Current_Declaration, use
|
||||
-- its Sloc as the location of all generated nodes.
|
||||
|
||||
Subp_Def : constant Entity_Id :=
|
||||
Defining_Unit_Name
|
||||
(Specification (Current_Declaration));
|
||||
|
||||
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));
|
||||
|
||||
Proxy_Object_Addr : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Build receiving stub
|
||||
|
||||
Current_Stubs :=
|
||||
Build_Subprogram_Receiving_Stubs
|
||||
(Vis_Decl => Current_Declaration,
|
||||
Asynchronous =>
|
||||
Nkind (Specification (Current_Declaration)) =
|
||||
N_Procedure_Specification
|
||||
and then Is_Asynchronous (Subp_Def));
|
||||
|
||||
Append_To (Decls, Current_Stubs);
|
||||
Analyze (Current_Stubs);
|
||||
|
||||
-- Build RAS proxy
|
||||
|
||||
Add_RAS_Proxy_And_Analyze (Decls,
|
||||
Vis_Decl => Current_Declaration,
|
||||
All_Calls_Remote_E => All_Calls_Remote_E,
|
||||
Proxy_Object_Addr => Proxy_Object_Addr);
|
||||
|
||||
-- Compute distribution identifier
|
||||
|
||||
Assign_Subprogram_Identifier
|
||||
(Subp_Def,
|
||||
Current_Subprogram_Number,
|
||||
Subp_Val);
|
||||
|
||||
pragma Assert
|
||||
(Current_Subprogram_Number = Get_Subprogram_Id (Subp_Def));
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Subp_Dist_Name,
|
||||
Constant_Present => True,
|
||||
Object_Definition =>
|
||||
New_Occurrence_Of (Standard_String, Loc),
|
||||
Expression =>
|
||||
Make_String_Literal (Loc, Subp_Val)));
|
||||
Analyze (Last (Decls));
|
||||
|
||||
-- Add subprogram descriptor (RCI_Subp_Info) to the
|
||||
-- subprograms table for this receiver. The aggregate
|
||||
-- below must be kept consistent with the declaration
|
||||
-- of type RCI_Subp_Info in System.Partition_Interface.
|
||||
|
||||
Append_To (Subp_Info_List,
|
||||
Make_Component_Association (Loc,
|
||||
Choices => New_List (
|
||||
Make_Integer_Literal (Loc, Current_Subprogram_Number)),
|
||||
|
||||
Expression =>
|
||||
Make_Aggregate (Loc,
|
||||
Expressions => New_List (
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Subp_Dist_Name, Loc),
|
||||
Attribute_Name => Name_Address),
|
||||
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Subp_Dist_Name, Loc),
|
||||
Attribute_Name => Name_Length),
|
||||
|
||||
New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
|
||||
|
||||
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
|
||||
Declaration => Current_Declaration,
|
||||
Stubs => Current_Stubs,
|
||||
Subp_Number => Current_Subprogram_Number,
|
||||
Subp_Dist_Name => Subp_Dist_Name,
|
||||
Subp_Proxy_Addr => Proxy_Object_Addr);
|
||||
end;
|
||||
|
||||
Current_Subprogram_Number := Current_Subprogram_Number + 1;
|
||||
end if;
|
||||
|
||||
-- Need to handle case of a nested package???
|
||||
|
||||
Next (Current_Declaration);
|
||||
end loop;
|
||||
Visit_Spec (Pkg_Spec);
|
||||
|
||||
Append_To (Decls,
|
||||
Make_Object_Declaration (Loc,
|
||||
|
||||
@ -507,7 +507,9 @@ package body Impunit is
|
||||
Non_Imp_File_Names_12 : constant File_List := (
|
||||
"s-multip", -- System.Multiprocessors
|
||||
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
|
||||
"a-cobove"); -- Ada.Containers.Bounded_Vectors
|
||||
"a-cobove", -- Ada.Containers.Bounded_Vectors
|
||||
"a-cborse", -- Ada.Containers.Bounded_Ordered_Sets
|
||||
"a-cborma"); -- Ada.Containers.Bounded_Ordered_Maps
|
||||
|
||||
-----------------------
|
||||
-- Alternative Units --
|
||||
|
||||
@ -3314,12 +3314,13 @@ package body Sem_Ch12 is
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- If we are generating the calling stubs from the instantiation of
|
||||
-- a generic RCI package, we will not use the body of the generic
|
||||
-- package.
|
||||
-- If we are generating calling stubs, we never need a body for an
|
||||
-- instantiation from source. However normal processing occurs for
|
||||
-- any generic instantiation appearing in generated code, since we
|
||||
-- do not generate stubs in that case.
|
||||
|
||||
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
|
||||
and then Is_Compilation_Unit (Defining_Entity (N))
|
||||
and then Comes_From_Source (N)
|
||||
then
|
||||
Needs_Body := False;
|
||||
end if;
|
||||
@ -4000,6 +4001,9 @@ package body Sem_Ch12 is
|
||||
Check_Formal_Packages (Pack_Id);
|
||||
Set_Is_Generic_Instance (Pack_Id, False);
|
||||
|
||||
-- Why do we clear Is_Generic_Instance??? We set it 20 lines
|
||||
-- above???
|
||||
|
||||
-- Body of the enclosing package is supplied when instantiating the
|
||||
-- subprogram body, after semantic analysis is completed.
|
||||
|
||||
|
||||
@ -12949,9 +12949,18 @@ package body Sem_Ch3 is
|
||||
Collect_Primitive_Operations (Parent_Type);
|
||||
|
||||
function Check_Derived_Type return Boolean;
|
||||
-- Check that all primitive inherited from Parent_Type are found in
|
||||
-- Check that all the entities derived from Parent_Type are found in
|
||||
-- the list of primitives of Derived_Type exactly in the same order.
|
||||
|
||||
procedure Derive_Interface_Subprogram
|
||||
(New_Subp : in out Entity_Id;
|
||||
Subp : Entity_Id;
|
||||
Actual_Subp : Entity_Id);
|
||||
-- Derive New_Subp from the ultimate alias of the parent subprogram Subp
|
||||
-- (which is an interface primitive). If Generic_Actual is present then
|
||||
-- Actual_Subp is the actual subprogram corresponding with the generic
|
||||
-- subprogram Subp.
|
||||
|
||||
function Check_Derived_Type return Boolean is
|
||||
E : Entity_Id;
|
||||
Elmt : Elmt_Id;
|
||||
@ -13027,6 +13036,45 @@ package body Sem_Ch3 is
|
||||
return True;
|
||||
end Check_Derived_Type;
|
||||
|
||||
---------------------------------
|
||||
-- Derive_Interface_Subprogram --
|
||||
---------------------------------
|
||||
|
||||
procedure Derive_Interface_Subprogram
|
||||
(New_Subp : in out Entity_Id;
|
||||
Subp : Entity_Id;
|
||||
Actual_Subp : Entity_Id)
|
||||
is
|
||||
Iface_Subp : constant Entity_Id := Ultimate_Alias (Subp);
|
||||
Iface_Type : constant Entity_Id := Find_Dispatching_Type (Iface_Subp);
|
||||
|
||||
begin
|
||||
pragma Assert (Is_Interface (Iface_Type));
|
||||
|
||||
Derive_Subprogram
|
||||
(New_Subp => New_Subp,
|
||||
Parent_Subp => Iface_Subp,
|
||||
Derived_Type => Derived_Type,
|
||||
Parent_Type => Iface_Type,
|
||||
Actual_Subp => Actual_Subp);
|
||||
|
||||
-- Given that this new interface entity corresponds with a primitive
|
||||
-- of the parent that was not overridden we must leave it associated
|
||||
-- with its parent primitive to ensure that it will share the same
|
||||
-- dispatch table slot when overridden.
|
||||
|
||||
if No (Actual_Subp) then
|
||||
Set_Alias (New_Subp, Subp);
|
||||
|
||||
-- For instantiations this is not needed since the previous call to
|
||||
-- Derive_Subprogram leaves the entity well decorated.
|
||||
|
||||
else
|
||||
pragma Assert (Alias (New_Subp) = Actual_Subp);
|
||||
null;
|
||||
end if;
|
||||
end Derive_Interface_Subprogram;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Alias_Subp : Entity_Id;
|
||||
@ -13179,7 +13227,7 @@ package body Sem_Ch3 is
|
||||
Alias_Subp := Ultimate_Alias (Subp);
|
||||
|
||||
-- Do not derive internal entities of the parent that link
|
||||
-- interface primitives and its covering primitive. These
|
||||
-- interface primitives with their covering primitive. These
|
||||
-- entities will be added to this type when frozen.
|
||||
|
||||
if Present (Interface_Alias (Subp)) then
|
||||
@ -13334,15 +13382,74 @@ package body Sem_Ch3 is
|
||||
(Nkind (Parent (Alias_Subp)) = N_Procedure_Specification
|
||||
and then Null_Present (Parent (Alias_Subp)))
|
||||
then
|
||||
Derive_Subprogram
|
||||
(New_Subp => New_Subp,
|
||||
Parent_Subp => Alias_Subp,
|
||||
Derived_Type => Derived_Type,
|
||||
Parent_Type => Find_Dispatching_Type (Alias_Subp),
|
||||
Actual_Subp => Act_Subp);
|
||||
-- If this is an abstract private type then we transfer the
|
||||
-- derivation of the interface primitive from the partial view
|
||||
-- to the full view. This is safe because all the interfaces
|
||||
-- must be visible in the partial view. Done to avoid adding
|
||||
-- a new interface derivation to the private part of the
|
||||
-- enclosing package; otherwise this new derivation would be
|
||||
-- decorated as hidden when the analysis of the enclosing
|
||||
-- package completes.
|
||||
|
||||
if No (Generic_Actual) then
|
||||
Set_Alias (New_Subp, Subp);
|
||||
if Is_Abstract_Type (Derived_Type)
|
||||
and then In_Private_Part (Current_Scope)
|
||||
and then Has_Private_Declaration (Derived_Type)
|
||||
then
|
||||
declare
|
||||
Partial_View : Entity_Id;
|
||||
Elmt : Elmt_Id;
|
||||
Ent : Entity_Id;
|
||||
|
||||
begin
|
||||
Partial_View := First_Entity (Current_Scope);
|
||||
loop
|
||||
exit when No (Partial_View)
|
||||
or else (Has_Private_Declaration (Partial_View)
|
||||
and then
|
||||
Full_View (Partial_View) = Derived_Type);
|
||||
|
||||
Next_Entity (Partial_View);
|
||||
end loop;
|
||||
|
||||
-- If the partial view was not found then the source code
|
||||
-- has errors and the derivation is not needed.
|
||||
|
||||
if Present (Partial_View) then
|
||||
Elmt :=
|
||||
First_Elmt (Primitive_Operations (Partial_View));
|
||||
while Present (Elmt) loop
|
||||
Ent := Node (Elmt);
|
||||
|
||||
if Present (Alias (Ent))
|
||||
and then Ultimate_Alias (Ent) = Alias (Subp)
|
||||
then
|
||||
Append_Elmt
|
||||
(Ent, Primitive_Operations (Derived_Type));
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Elmt);
|
||||
end loop;
|
||||
|
||||
-- If the interface primitive was not found in the
|
||||
-- partial view then this interface primitive was
|
||||
-- overridden. We add a derivation to activate in
|
||||
-- Derive_Progenitor_Subprograms the machinery to
|
||||
-- search for it.
|
||||
|
||||
if No (Elmt) then
|
||||
Derive_Interface_Subprogram
|
||||
(New_Subp => New_Subp,
|
||||
Subp => Subp,
|
||||
Actual_Subp => Act_Subp);
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
else
|
||||
Derive_Interface_Subprogram
|
||||
(New_Subp => New_Subp,
|
||||
Subp => Subp,
|
||||
Actual_Subp => Act_Subp);
|
||||
end if;
|
||||
|
||||
-- Case 3: Common derivation
|
||||
|
||||
@ -3045,9 +3045,9 @@ package body Sem_Util is
|
||||
Set_Scope (Def_Id, Current_Scope);
|
||||
return;
|
||||
|
||||
-- Analogous to privals, the discriminal generated for an entry
|
||||
-- index parameter acts as a weak declaration. Perform minimal
|
||||
-- decoration to avoid bogus errors.
|
||||
-- Analogous to privals, the discriminal generated for an entry index
|
||||
-- parameter acts as a weak declaration. Perform minimal decoration
|
||||
-- to avoid bogus errors.
|
||||
|
||||
elsif Is_Discriminal (Def_Id)
|
||||
and then Ekind (Discriminal_Link (Def_Id)) = E_Entry_Index_Parameter
|
||||
@ -3055,11 +3055,10 @@ package body Sem_Util is
|
||||
Set_Scope (Def_Id, Current_Scope);
|
||||
return;
|
||||
|
||||
-- In the body or private part of an instance, a type extension
|
||||
-- may introduce a component with the same name as that of an
|
||||
-- actual. The legality rule is not enforced, but the semantics
|
||||
-- of the full type with two components of the same name are not
|
||||
-- clear at this point ???
|
||||
-- In the body or private part of an instance, a type extension may
|
||||
-- introduce a component with the same name as that of an actual. The
|
||||
-- legality rule is not enforced, but the semantics of the full type
|
||||
-- with two components of same name are not clear at this point???
|
||||
|
||||
elsif In_Instance_Not_Visible then
|
||||
null;
|
||||
@ -3073,9 +3072,9 @@ package body Sem_Util is
|
||||
then
|
||||
null;
|
||||
|
||||
-- Conversely, with front-end inlining we may compile the parent
|
||||
-- body first, and a child unit subsequently. The context is now
|
||||
-- the parent spec, and body entities are not visible.
|
||||
-- Conversely, with front-end inlining we may compile the parent body
|
||||
-- first, and a child unit subsequently. The context is now the
|
||||
-- parent spec, and body entities are not visible.
|
||||
|
||||
elsif Is_Child_Unit (Def_Id)
|
||||
and then Is_Package_Body_Entity (E)
|
||||
@ -3089,8 +3088,8 @@ package body Sem_Util is
|
||||
Error_Msg_Sloc := Sloc (E);
|
||||
|
||||
-- If the previous declaration is an incomplete type declaration
|
||||
-- this may be an attempt to complete it with a private type.
|
||||
-- The following avoids confusing cascaded errors.
|
||||
-- this may be an attempt to complete it with a private type. The
|
||||
-- following avoids confusing cascaded errors.
|
||||
|
||||
if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
|
||||
and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
|
||||
@ -3113,9 +3112,9 @@ package body Sem_Util is
|
||||
Error_Msg_N ("& conflicts with declaration#", E);
|
||||
return;
|
||||
|
||||
-- If the name of the unit appears in its own context clause,
|
||||
-- a dummy package with the name has already been created, and
|
||||
-- the error emitted. Try to continue quietly.
|
||||
-- If the name of the unit appears in its own context clause, a
|
||||
-- dummy package with the name has already been created, and the
|
||||
-- error emitted. Try to continue quietly.
|
||||
|
||||
elsif Error_Posted (E)
|
||||
and then Sloc (E) = No_Location
|
||||
@ -3144,9 +3143,9 @@ package body Sem_Util is
|
||||
Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
|
||||
end if;
|
||||
|
||||
-- If entity is in standard, then we are in trouble, because
|
||||
-- it means that we have a library package with a duplicated
|
||||
-- name. That's hard to recover from, so abort!
|
||||
-- If entity is in standard, then we are in trouble, because it
|
||||
-- means that we have a library package with a duplicated name.
|
||||
-- That's hard to recover from, so abort!
|
||||
|
||||
if S = Standard_Standard then
|
||||
raise Unrecoverable_Error;
|
||||
@ -3160,17 +3159,17 @@ package body Sem_Util is
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If we fall through, declaration is OK , or OK enough to continue
|
||||
-- If we fall through, declaration is OK, at least OK enough to continue
|
||||
|
||||
-- If Def_Id is a discriminant or a record component we are in the
|
||||
-- midst of inheriting components in a derived record definition.
|
||||
-- Preserve their Ekind and Etype.
|
||||
-- If Def_Id is a discriminant or a record component we are in the midst
|
||||
-- of inheriting components in a derived record definition. Preserve
|
||||
-- their Ekind and Etype.
|
||||
|
||||
if Ekind_In (Def_Id, E_Discriminant, E_Component) then
|
||||
null;
|
||||
|
||||
-- If a type is already set, leave it alone (happens whey a type
|
||||
-- declaration is reanalyzed following a call to the optimizer)
|
||||
-- If a type is already set, leave it alone (happens when a type
|
||||
-- declaration is reanalyzed following a call to the optimizer).
|
||||
|
||||
elsif Present (Etype (Def_Id)) then
|
||||
null;
|
||||
@ -3227,8 +3226,8 @@ package body Sem_Util is
|
||||
|
||||
and then In_Extended_Main_Source_Unit (Def_Id)
|
||||
|
||||
-- Finally, the hidden entity must be either immediately visible
|
||||
-- or use visible (from a used package)
|
||||
-- Finally, the hidden entity must be either immediately visible or
|
||||
-- use visible (i.e. from a used package).
|
||||
|
||||
and then
|
||||
(Is_Immediately_Visible (C)
|
||||
|
||||
@ -425,8 +425,8 @@ begin
|
||||
Write_Line (" F* turn off warnings for unreferenced formal");
|
||||
Write_Line (" g*+ turn on warnings for unrecognized pragma");
|
||||
Write_Line (" G turn off warnings for unrecognized pragma");
|
||||
Write_Line (" h turn on warnings for hiding variable");
|
||||
Write_Line (" H* turn off warnings for hiding variable");
|
||||
Write_Line (" h turn on warnings for hiding declarations");
|
||||
Write_Line (" H* turn off warnings for hiding declarations");
|
||||
Write_Line (" .h turn on warnings for holes in records");
|
||||
Write_Line (" .H* turn off warnings for holes in records");
|
||||
Write_Line (" i*+ turn on warnings for implementation unit");
|
||||
|
||||
Loading…
Reference in New Issue
Block a user