gcc/ada/libgnat/a-cofuba.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      ADA.CONTAINERS.FUNCTIONAL_BASE                      --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2016-2018, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  21 --                                                                          --
  22 -- As a special exception under Section 7 of GPL version 3, you are granted --
  23 -- additional permissions described in the GCC Runtime Library Exception,   --
  24 -- version 3.1, as published by the Free Software Foundation.               --
  25 --                                                                          --
  26 -- You should have received a copy of the GNU General Public License and    --
  27 -- a copy of the GCC Runtime Library Exception along with this program;     --
  28 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  29 -- <http://www.gnu.org/licenses/>.                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Ada_2012;
  33
  34 package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
  35
  36    function To_Count (Idx : Extended_Index) return Count_Type is
  37      (Count_Type
  38        (Extended_Index'Pos (Idx) -
  39         Extended_Index'Pos (Extended_Index'First)));
  40
  41    function To_Index (Position : Count_Type) return Extended_Index is
  42      (Extended_Index'Val
  43        (Position + Extended_Index'Pos (Extended_Index'First)));
  44    --  Conversion functions between Index_Type and Count_Type
  45
  46    function Find (C : Container; E : access Element_Type) return Count_Type;
  47    --  Search a container C for an element equal to E.all, returning the
  48    --  position in the underlying array.
  49
  50    ---------
  51    -- "=" --
  52    ---------
  53
  54    function "=" (C1 : Container; C2 : Container) return Boolean is
  55    begin
  56       if C1.Elements'Length /= C2.Elements'Length then
  57          return False;
  58       end if;
  59
  60       for I in C1.Elements'Range loop
  61          if C1.Elements (I).all /= C2.Elements (I).all then
  62             return False;
  63          end if;
  64       end loop;
  65
  66       return True;
  67    end "=";
  68
  69    ----------
  70    -- "<=" --
  71    ----------
  72
  73    function "<=" (C1 : Container; C2 : Container) return Boolean is
  74    begin
  75       for I in C1.Elements'Range loop
  76          if Find (C2, C1.Elements (I)) = 0 then
  77             return False;
  78          end if;
  79       end loop;
  80
  81       return True;
  82    end "<=";
  83
  84    ---------
  85    -- Add --
  86    ---------
  87
  88    function Add
  89      (C : Container;
  90       I : Index_Type;
  91       E : Element_Type) return Container
  92    is
  93       A : constant Element_Array_Access :=
  94             new Element_Array'(1 .. C.Elements'Last + 1 => <>);
  95       P : Count_Type := 0;
  96
  97    begin
  98       for J in 1 .. C.Elements'Last + 1 loop
  99          if J /= To_Count (I) then
 100             P := P + 1;
 101             A (J) := C.Elements (P);
 102          else
 103             A (J) := new Element_Type'(E);
 104          end if;
 105       end loop;
 106
 107       return Container'(Elements => A);
 108    end Add;
 109
 110    ----------
 111    -- Find --
 112    ----------
 113
 114    function Find (C : Container; E : access Element_Type) return Count_Type is
 115    begin
 116       for I in C.Elements'Range loop
 117          if C.Elements (I).all = E.all then
 118             return I;
 119          end if;
 120       end loop;
 121
 122       return 0;
 123    end Find;
 124
 125    function Find (C : Container; E : Element_Type) return Extended_Index is
 126      (To_Index (Find (C, E'Unrestricted_Access)));
 127
 128    ---------
 129    -- Get --
 130    ---------
 131
 132    function Get (C : Container; I : Index_Type) return Element_Type is
 133      (C.Elements (To_Count (I)).all);
 134
 135    ------------------
 136    -- Intersection --
 137    ------------------
 138
 139    function Intersection (C1 : Container; C2 : Container) return Container is
 140       A : constant Element_Array_Access :=
 141             new Element_Array'(1 .. Num_Overlaps (C1, C2) => <>);
 142       P : Count_Type := 0;
 143
 144    begin
 145       for I in C1.Elements'Range loop
 146          if Find (C2, C1.Elements (I)) > 0 then
 147             P := P + 1;
 148             A (P) := C1.Elements (I);
 149          end if;
 150       end loop;
 151
 152       return Container'(Elements => A);
 153    end Intersection;
 154
 155    ------------
 156    -- Length --
 157    ------------
 158
 159    function Length (C : Container) return Count_Type is (C.Elements'Length);
 160
 161    ---------------------
 162    -- Num_Overlaps --
 163    ---------------------
 164
 165    function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
 166       P : Count_Type := 0;
 167
 168    begin
 169       for I in C1.Elements'Range loop
 170          if Find (C2, C1.Elements (I)) > 0 then
 171             P := P + 1;
 172          end if;
 173       end loop;
 174
 175       return P;
 176    end Num_Overlaps;
 177
 178    ------------
 179    -- Remove --
 180    ------------
 181
 182    function Remove (C : Container; I : Index_Type) return Container is
 183       A : constant Element_Array_Access :=
 184             new Element_Array'(1 .. C.Elements'Last - 1 => <>);
 185       P : Count_Type := 0;
 186
 187    begin
 188       for J in C.Elements'Range loop
 189          if J /= To_Count (I) then
 190             P := P + 1;
 191             A (P) := C.Elements (J);
 192          end if;
 193       end loop;
 194
 195       return Container'(Elements => A);
 196    end Remove;
 197
 198    ---------
 199    -- Set --
 200    ---------
 201
 202    function Set
 203      (C : Container;
 204       I : Index_Type;
 205       E : Element_Type) return Container
 206    is
 207       Result : constant Container :=
 208                  Container'(Elements => new Element_Array'(C.Elements.all));
 209
 210    begin
 211       Result.Elements (To_Count (I)) := new Element_Type'(E);
 212       return Result;
 213    end Set;
 214
 215    -----------
 216    -- Union --
 217    -----------
 218
 219    function Union (C1 : Container; C2 : Container) return Container is
 220       N : constant Count_Type := Num_Overlaps (C1, C2);
 221
 222    begin
 223       --  if C2 is completely included in C1 then return C1
 224
 225       if N = Length (C2) then
 226          return C1;
 227       end if;
 228
 229       --  else loop through C2 to find the remaining elements
 230
 231       declare
 232          L : constant Count_Type := Length (C1) - N + Length (C2);
 233          A : constant Element_Array_Access :=
 234                new Element_Array'
 235                      (C1.Elements.all & (Length (C1) + 1 .. L => <>));
 236          P : Count_Type := Length (C1);
 237
 238       begin
 239          for I in C2.Elements'Range loop
 240             if Find (C1, C2.Elements (I)) = 0 then
 241                P := P + 1;
 242                A (P) := C2.Elements (I);
 243             end if;
 244          end loop;
 245
 246          return Container'(Elements => A);
 247       end;
 248    end Union;
 249
 250 end Ada.Containers.Functional_Base;