1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . A R R A Y _ S P L I T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Unchecked_Deallocation; 33 34package body GNAT.Array_Split is 35 36 procedure Free is 37 new Ada.Unchecked_Deallocation (Slices_Indexes, Slices_Access); 38 39 procedure Free is 40 new Ada.Unchecked_Deallocation (Separators_Indexes, Indexes_Access); 41 42 function Count 43 (Source : Element_Sequence; 44 Pattern : Element_Set) return Natural; 45 -- Returns the number of occurrences of Pattern elements in Source, 0 is 46 -- returned if no occurrence is found in Source. 47 48 ------------ 49 -- Adjust -- 50 ------------ 51 52 overriding procedure Adjust (S : in out Slice_Set) is 53 begin 54 S.D.Ref_Counter := S.D.Ref_Counter + 1; 55 end Adjust; 56 57 ------------ 58 -- Create -- 59 ------------ 60 61 procedure Create 62 (S : out Slice_Set; 63 From : Element_Sequence; 64 Separators : Element_Sequence; 65 Mode : Separator_Mode := Single) 66 is 67 begin 68 Create (S, From, To_Set (Separators), Mode); 69 end Create; 70 71 function Create 72 (From : Element_Sequence; 73 Separators : Element_Sequence; 74 Mode : Separator_Mode := Single) return Slice_Set is 75 begin 76 return Ret : Slice_Set do 77 Create (Ret, From, Separators, Mode); 78 end return; 79 end Create; 80 81 ------------ 82 -- Create -- 83 ------------ 84 85 procedure Create 86 (S : out Slice_Set; 87 From : Element_Sequence; 88 Separators : Element_Set; 89 Mode : Separator_Mode := Single) 90 is 91 Result : Slice_Set; 92 begin 93 Result.D.Source := new Element_Sequence'(From); 94 Set (Result, Separators, Mode); 95 S := Result; 96 end Create; 97 98 function Create 99 (From : Element_Sequence; 100 Separators : Element_Set; 101 Mode : Separator_Mode := Single) return Slice_Set is 102 begin 103 return Ret : Slice_Set do 104 Create (Ret, From, Separators, Mode); 105 end return; 106 end Create; 107 108 ----------- 109 -- Count -- 110 ----------- 111 112 function Count 113 (Source : Element_Sequence; 114 Pattern : Element_Set) return Natural 115 is 116 C : Natural := 0; 117 begin 118 for K in Source'Range loop 119 if Is_In (Source (K), Pattern) then 120 C := C + 1; 121 end if; 122 end loop; 123 124 return C; 125 end Count; 126 127 -------------- 128 -- Finalize -- 129 -------------- 130 131 overriding procedure Finalize (S : in out Slice_Set) is 132 133 procedure Free is 134 new Ada.Unchecked_Deallocation (Element_Sequence, Element_Access); 135 136 procedure Free is 137 new Ada.Unchecked_Deallocation (Data, Data_Access); 138 139 D : Data_Access := S.D; 140 141 begin 142 -- Ensure call is idempotent 143 144 S.D := null; 145 146 if D /= null then 147 D.Ref_Counter := D.Ref_Counter - 1; 148 149 if D.Ref_Counter = 0 then 150 Free (D.Source); 151 Free (D.Indexes); 152 Free (D.Slices); 153 Free (D); 154 end if; 155 end if; 156 end Finalize; 157 158 ---------------- 159 -- Initialize -- 160 ---------------- 161 162 overriding procedure Initialize (S : in out Slice_Set) is 163 begin 164 S.D := new Data'(1, null, 0, null, null); 165 end Initialize; 166 167 ---------------- 168 -- Separators -- 169 ---------------- 170 171 function Separators 172 (S : Slice_Set; 173 Index : Slice_Number) return Slice_Separators 174 is 175 begin 176 if Index > S.D.N_Slice then 177 raise Index_Error; 178 179 elsif Index = 0 180 or else (Index = 1 and then S.D.N_Slice = 1) 181 then 182 -- Whole string, or no separator used 183 184 return (Before => Array_End, 185 After => Array_End); 186 187 elsif Index = 1 then 188 return (Before => Array_End, 189 After => S.D.Source (S.D.Slices (Index).Stop + 1)); 190 191 elsif Index = S.D.N_Slice then 192 return (Before => S.D.Source (S.D.Slices (Index).Start - 1), 193 After => Array_End); 194 195 else 196 return (Before => S.D.Source (S.D.Slices (Index).Start - 1), 197 After => S.D.Source (S.D.Slices (Index).Stop + 1)); 198 end if; 199 end Separators; 200 201 ---------------- 202 -- Separators -- 203 ---------------- 204 205 function Separators (S : Slice_Set) return Separators_Indexes is 206 begin 207 return S.D.Indexes.all; 208 end Separators; 209 210 --------- 211 -- Set -- 212 --------- 213 214 procedure Set 215 (S : in out Slice_Set; 216 Separators : Element_Sequence; 217 Mode : Separator_Mode := Single) 218 is 219 begin 220 Set (S, To_Set (Separators), Mode); 221 end Set; 222 223 --------- 224 -- Set -- 225 --------- 226 227 procedure Set 228 (S : in out Slice_Set; 229 Separators : Element_Set; 230 Mode : Separator_Mode := Single) 231 is 232 233 procedure Copy_On_Write (S : in out Slice_Set); 234 -- Make a copy of S if shared with another variable 235 236 ------------------- 237 -- Copy_On_Write -- 238 ------------------- 239 240 procedure Copy_On_Write (S : in out Slice_Set) is 241 begin 242 if S.D.Ref_Counter > 1 then 243 -- First let's remove our count from the current data 244 245 S.D.Ref_Counter := S.D.Ref_Counter - 1; 246 247 -- Then duplicate the data 248 249 S.D := new Data'(S.D.all); 250 S.D.Ref_Counter := 1; 251 252 if S.D.Source /= null then 253 S.D.Source := new Element_Sequence'(S.D.Source.all); 254 S.D.Indexes := null; 255 S.D.Slices := null; 256 end if; 257 258 else 259 -- If there is a single reference to this variable, free it now 260 -- as it will be redefined below. 261 262 Free (S.D.Indexes); 263 Free (S.D.Slices); 264 end if; 265 end Copy_On_Write; 266 267 Count_Sep : constant Natural := Count (S.D.Source.all, Separators); 268 J : Positive; 269 270 begin 271 Copy_On_Write (S); 272 273 -- Compute all separator's indexes 274 275 S.D.Indexes := new Separators_Indexes (1 .. Count_Sep); 276 J := S.D.Indexes'First; 277 278 for K in S.D.Source'Range loop 279 if Is_In (S.D.Source (K), Separators) then 280 S.D.Indexes (J) := K; 281 J := J + 1; 282 end if; 283 end loop; 284 285 -- Compute slice info for fast slice access 286 287 declare 288 S_Info : Slices_Indexes (1 .. Slice_Number (Count_Sep) + 1); 289 K : Natural := 1; 290 Start, Stop : Natural; 291 292 begin 293 S.D.N_Slice := 0; 294 295 Start := S.D.Source'First; 296 Stop := 0; 297 298 loop 299 if K > Count_Sep then 300 301 -- No more separators, last slice ends at end of source string 302 303 Stop := S.D.Source'Last; 304 305 else 306 Stop := S.D.Indexes (K) - 1; 307 end if; 308 309 -- Add slice to the table 310 311 S.D.N_Slice := S.D.N_Slice + 1; 312 S_Info (S.D.N_Slice) := (Start, Stop); 313 314 exit when K > Count_Sep; 315 316 case Mode is 317 when Single => 318 319 -- In this mode just set start to character next to the 320 -- current separator, advance the separator index. 321 322 Start := S.D.Indexes (K) + 1; 323 K := K + 1; 324 325 when Multiple => 326 327 -- In this mode skip separators following each other 328 329 loop 330 Start := S.D.Indexes (K) + 1; 331 K := K + 1; 332 exit when K > Count_Sep 333 or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1; 334 end loop; 335 end case; 336 end loop; 337 338 S.D.Slices := new Slices_Indexes'(S_Info (1 .. S.D.N_Slice)); 339 end; 340 end Set; 341 342 ----------- 343 -- Slice -- 344 ----------- 345 346 function Slice 347 (S : Slice_Set; 348 Index : Slice_Number) return Element_Sequence 349 is 350 begin 351 if Index = 0 then 352 return S.D.Source.all; 353 354 elsif Index > S.D.N_Slice then 355 raise Index_Error; 356 357 else 358 return 359 S.D.Source (S.D.Slices (Index).Start .. S.D.Slices (Index).Stop); 360 end if; 361 end Slice; 362 363 ----------------- 364 -- Slice_Count -- 365 ----------------- 366 367 function Slice_Count (S : Slice_Set) return Slice_Number is 368 begin 369 return S.D.N_Slice; 370 end Slice_Count; 371 372end GNAT.Array_Split; 373