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-2020, 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 with Ada.Unchecked_Deallocation;
  34
  35 package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
  36
  37    function To_Count (Idx : Extended_Index) return Count_Type is
  38      (Count_Type
  39        (Extended_Index'Pos (Idx) -
  40         Extended_Index'Pos (Extended_Index'First)));
  41
  42    function To_Index (Position : Count_Type) return Extended_Index is
  43      (Extended_Index'Val
  44        (Position + Extended_Index'Pos (Extended_Index'First)));
  45    --  Conversion functions between Index_Type and Count_Type
  46
  47    function Find (C : Container; E : access Element_Type) return Count_Type;
  48    --  Search a container C for an element equal to E.all, returning the
  49    --  position in the underlying array.
  50
  51    procedure Resize (Base : Array_Base_Access);
  52    --  Resize the underlying array if needed so that it can contain one more
  53    --  element.
  54
  55    ---------
  56    -- "=" --
  57    ---------
  58
  59    function "=" (C1 : Container; C2 : Container) return Boolean is
  60    begin
  61       if C1.Length /= C2.Length then
  62          return False;
  63       end if;
  64
  65       for I in 1 .. C1.Length loop
  66          if C1.Base.Elements (I).all /= C2.Base.Elements (I).all then
  67             return False;
  68          end if;
  69       end loop;
  70
  71       return True;
  72    end "=";
  73
  74    ----------
  75    -- "<=" --
  76    ----------
  77
  78    function "<=" (C1 : Container; C2 : Container) return Boolean is
  79    begin
  80       for I in 1 .. C1.Length loop
  81          if Find (C2, C1.Base.Elements (I)) = 0 then
  82             return False;
  83          end if;
  84       end loop;
  85
  86       return True;
  87    end "<=";
  88
  89    ---------
  90    -- Add --
  91    ---------
  92
  93    function Add
  94      (C : Container;
  95       I : Index_Type;
  96       E : Element_Type) return Container
  97    is
  98    begin
  99       if To_Count (I) = C.Length + 1 and then C.Length = C.Base.Max_Length then
 100          Resize (C.Base);
 101          C.Base.Max_Length := C.Base.Max_Length + 1;
 102          C.Base.Elements (C.Base.Max_Length) := new Element_Type'(E);
 103
 104          return Container'(Length => C.Base.Max_Length, Base => C.Base);
 105       else
 106          declare
 107             A : constant Array_Base_Access := Content_Init (C.Length);
 108             P : Count_Type := 0;
 109          begin
 110             A.Max_Length := C.Length + 1;
 111             for J in 1 .. C.Length + 1 loop
 112                if J /= To_Count (I) then
 113                   P := P + 1;
 114                   A.Elements (J) := C.Base.Elements (P);
 115                else
 116                   A.Elements (J) := new Element_Type'(E);
 117                end if;
 118             end loop;
 119
 120             return Container'(Length => A.Max_Length,
 121                               Base   => A);
 122          end;
 123       end if;
 124    end Add;
 125
 126    ------------------
 127    -- Content_Init --
 128    ------------------
 129
 130    function Content_Init (L : Count_Type := 0) return Array_Base_Access
 131    is
 132       Max_Init : constant Count_Type := 100;
 133       Size     : constant Count_Type :=
 134         (if L < Count_Type'Last - Max_Init then L + Max_Init
 135          else Count_Type'Last);
 136       Elements : constant Element_Array_Access :=
 137         new Element_Array'(1 .. Size => <>);
 138    begin
 139       return new Array_Base'(Max_Length => 0, Elements => Elements);
 140    end Content_Init;
 141
 142    ----------
 143    -- Find --
 144    ----------
 145
 146    function Find (C : Container; E : access Element_Type) return Count_Type is
 147    begin
 148       for I in 1 .. C.Length loop
 149          if C.Base.Elements (I).all = E.all then
 150             return I;
 151          end if;
 152       end loop;
 153
 154       return 0;
 155    end Find;
 156
 157    function Find (C : Container; E : Element_Type) return Extended_Index is
 158      (To_Index (Find (C, E'Unrestricted_Access)));
 159
 160    ---------
 161    -- Get --
 162    ---------
 163
 164    function Get (C : Container; I : Index_Type) return Element_Type is
 165      (C.Base.Elements (To_Count (I)).all);
 166
 167    ------------------
 168    -- Intersection --
 169    ------------------
 170
 171    function Intersection (C1 : Container; C2 : Container) return Container is
 172       L : constant Count_Type := Num_Overlaps (C1, C2);
 173       A : constant Array_Base_Access := Content_Init (L);
 174       P : Count_Type := 0;
 175
 176    begin
 177       A.Max_Length := L;
 178       for I in 1 .. C1.Length loop
 179          if Find (C2, C1.Base.Elements (I)) > 0 then
 180             P := P + 1;
 181             A.Elements (P) := C1.Base.Elements (I);
 182          end if;
 183       end loop;
 184
 185       return Container'(Length => P, Base => A);
 186    end Intersection;
 187
 188    ------------
 189    -- Length --
 190    ------------
 191
 192    function Length (C : Container) return Count_Type is (C.Length);
 193    ---------------------
 194    -- Num_Overlaps --
 195    ---------------------
 196
 197    function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is
 198       P : Count_Type := 0;
 199
 200    begin
 201       for I in 1 .. C1.Length loop
 202          if Find (C2, C1.Base.Elements (I)) > 0 then
 203             P := P + 1;
 204          end if;
 205       end loop;
 206
 207       return P;
 208    end Num_Overlaps;
 209
 210    ------------
 211    -- Remove --
 212    ------------
 213
 214    function Remove (C : Container; I : Index_Type) return Container is
 215    begin
 216       if To_Count (I) = C.Length then
 217          return Container'(Length => C.Length - 1, Base => C.Base);
 218       else
 219          declare
 220             A : constant Array_Base_Access := Content_Init (C.Length - 1);
 221             P : Count_Type := 0;
 222          begin
 223             A.Max_Length := C.Length - 1;
 224             for J in 1 .. C.Length loop
 225                if J /= To_Count (I) then
 226                   P := P + 1;
 227                   A.Elements (P) := C.Base.Elements (J);
 228                end if;
 229             end loop;
 230
 231             return Container'(Length => C.Length - 1, Base => A);
 232          end;
 233       end if;
 234    end Remove;
 235
 236    ------------
 237    -- Resize --
 238    ------------
 239
 240    procedure Resize (Base : Array_Base_Access) is
 241    begin
 242       if Base.Max_Length < Base.Elements'Length then
 243          return;
 244       end if;
 245
 246       pragma Assert (Base.Max_Length = Base.Elements'Length);
 247
 248       if Base.Max_Length = Count_Type'Last then
 249          raise Constraint_Error;
 250       end if;
 251
 252       declare
 253          procedure Finalize is new Ada.Unchecked_Deallocation
 254            (Object => Element_Array,
 255             Name   => Element_Array_Access_Base);
 256
 257          New_Length : constant Positive_Count_Type :=
 258            (if Base.Max_Length > Count_Type'Last / 2 then Count_Type'Last
 259             else 2 * Base.Max_Length);
 260          Elements   : constant Element_Array_Access :=
 261            new Element_Array (1 .. New_Length);
 262          Old_Elmts  : Element_Array_Access_Base := Base.Elements;
 263       begin
 264          Elements (1 .. Base.Max_Length) := Base.Elements.all;
 265          Base.Elements := Elements;
 266          Finalize (Old_Elmts);
 267       end;
 268    end Resize;
 269
 270    ---------
 271    -- Set --
 272    ---------
 273
 274    function Set
 275      (C : Container;
 276       I : Index_Type;
 277       E : Element_Type) return Container
 278    is
 279       Result : constant Container :=
 280                  Container'(Length => C.Length,
 281                             Base => Content_Init (C.Length));
 282
 283    begin
 284       Result.Base.Max_Length := C.Length;
 285       Result.Base.Elements (1 .. C.Length) := C.Base.Elements (1 .. C.Length);
 286       Result.Base.Elements (To_Count (I)) := new Element_Type'(E);
 287       return Result;
 288    end Set;
 289
 290    -----------
 291    -- Union --
 292    -----------
 293
 294    function Union (C1 : Container; C2 : Container) return Container is
 295       N : constant Count_Type := Num_Overlaps (C1, C2);
 296
 297    begin
 298       --  if C2 is completely included in C1 then return C1
 299
 300       if N = Length (C2) then
 301          return C1;
 302       end if;
 303
 304       --  else loop through C2 to find the remaining elements
 305
 306       declare
 307          L : constant Count_Type := Length (C1) - N + Length (C2);
 308          A : constant Array_Base_Access := Content_Init (L);
 309          P : Count_Type := Length (C1);
 310
 311       begin
 312          A.Max_Length := L;
 313          A.Elements (1 .. C1.Length) := C1.Base.Elements (1 .. C1.Length);
 314          for I in 1 .. C2.Length loop
 315             if Find (C1, C2.Base.Elements (I)) = 0 then
 316                P := P + 1;
 317                A.Elements (P) := C2.Base.Elements (I);
 318             end if;
 319          end loop;
 320
 321          return Container'(Length => L, Base => A);
 322       end;
 323    end Union;
 324
 325 end Ada.Containers.Functional_Base;