1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S T R I N G S . W I D E _ M A P S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Ada.Strings.Wide_Maps is 35 36 --------- 37 -- "-" -- 38 --------- 39 40 function "-" 41 (Left, Right : Wide_Character_Set) return Wide_Character_Set 42 is 43 LS : constant Wide_Character_Ranges_Access := Left.Set; 44 RS : constant Wide_Character_Ranges_Access := Right.Set; 45 46 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); 47 -- Each range on the right can generate at least one more range in 48 -- the result, by splitting one of the left operand ranges. 49 50 N : Natural := 0; 51 R : Natural := 1; 52 L : Natural := 1; 53 54 Left_Low : Wide_Character; 55 -- Left_Low is lowest character of the L'th range not yet dealt with 56 57 begin 58 if LS'Last = 0 or else RS'Last = 0 then 59 return Left; 60 end if; 61 62 Left_Low := LS (L).Low; 63 while R <= RS'Last loop 64 65 -- If next right range is below current left range, skip it 66 67 if RS (R).High < Left_Low then 68 R := R + 1; 69 70 -- If next right range above current left range, copy remainder 71 -- of the left range to the result 72 73 elsif RS (R).Low > LS (L).High then 74 N := N + 1; 75 Result (N).Low := Left_Low; 76 Result (N).High := LS (L).High; 77 L := L + 1; 78 exit when L > LS'Last; 79 Left_Low := LS (L).Low; 80 81 else 82 -- Next right range overlaps bottom of left range 83 84 if RS (R).Low <= Left_Low then 85 86 -- Case of right range complete overlaps left range 87 88 if RS (R).High >= LS (L).High then 89 L := L + 1; 90 exit when L > LS'Last; 91 Left_Low := LS (L).Low; 92 93 -- Case of right range eats lower part of left range 94 95 else 96 Left_Low := Wide_Character'Succ (RS (R).High); 97 R := R + 1; 98 end if; 99 100 -- Next right range overlaps some of left range, but not bottom 101 102 else 103 N := N + 1; 104 Result (N).Low := Left_Low; 105 Result (N).High := Wide_Character'Pred (RS (R).Low); 106 107 -- Case of right range splits left range 108 109 if RS (R).High < LS (L).High then 110 Left_Low := Wide_Character'Succ (RS (R).High); 111 R := R + 1; 112 113 -- Case of right range overlaps top of left range 114 115 else 116 L := L + 1; 117 exit when L > LS'Last; 118 Left_Low := LS (L).Low; 119 end if; 120 end if; 121 end if; 122 end loop; 123 124 -- Copy remainder of left ranges to result 125 126 if L <= LS'Last then 127 N := N + 1; 128 Result (N).Low := Left_Low; 129 Result (N).High := LS (L).High; 130 131 loop 132 L := L + 1; 133 exit when L > LS'Last; 134 N := N + 1; 135 Result (N) := LS (L); 136 end loop; 137 end if; 138 139 return (AF.Controlled with 140 Set => new Wide_Character_Ranges'(Result (1 .. N))); 141 end "-"; 142 143 --------- 144 -- "=" -- 145 --------- 146 147 -- The sorted, discontiguous form is canonical, so equality can be used 148 149 function "=" (Left, Right : Wide_Character_Set) return Boolean is 150 begin 151 return Left.Set.all = Right.Set.all; 152 end "="; 153 154 ----------- 155 -- "and" -- 156 ----------- 157 158 function "and" 159 (Left, Right : Wide_Character_Set) return Wide_Character_Set 160 is 161 LS : constant Wide_Character_Ranges_Access := Left.Set; 162 RS : constant Wide_Character_Ranges_Access := Right.Set; 163 164 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); 165 N : Natural := 0; 166 L, R : Natural := 1; 167 168 begin 169 -- Loop to search for overlapping character ranges 170 171 while L <= LS'Last and then R <= RS'Last loop 172 173 if LS (L).High < RS (R).Low then 174 L := L + 1; 175 176 elsif RS (R).High < LS (L).Low then 177 R := R + 1; 178 179 -- Here we have LS (L).High >= RS (R).Low 180 -- and RS (R).High >= LS (L).Low 181 -- so we have an overlapping range 182 183 else 184 N := N + 1; 185 Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low); 186 Result (N).High := 187 Wide_Character'Min (LS (L).High, RS (R).High); 188 189 if RS (R).High = LS (L).High then 190 L := L + 1; 191 R := R + 1; 192 elsif RS (R).High < LS (L).High then 193 R := R + 1; 194 else 195 L := L + 1; 196 end if; 197 end if; 198 end loop; 199 200 return (AF.Controlled with 201 Set => new Wide_Character_Ranges'(Result (1 .. N))); 202 end "and"; 203 204 ----------- 205 -- "not" -- 206 ----------- 207 208 function "not" 209 (Right : Wide_Character_Set) return Wide_Character_Set 210 is 211 RS : constant Wide_Character_Ranges_Access := Right.Set; 212 213 Result : Wide_Character_Ranges (1 .. RS'Last + 1); 214 N : Natural := 0; 215 216 begin 217 if RS'Last = 0 then 218 N := 1; 219 Result (1) := (Low => Wide_Character'First, 220 High => Wide_Character'Last); 221 222 else 223 if RS (1).Low /= Wide_Character'First then 224 N := N + 1; 225 Result (N).Low := Wide_Character'First; 226 Result (N).High := Wide_Character'Pred (RS (1).Low); 227 end if; 228 229 for K in 1 .. RS'Last - 1 loop 230 N := N + 1; 231 Result (N).Low := Wide_Character'Succ (RS (K).High); 232 Result (N).High := Wide_Character'Pred (RS (K + 1).Low); 233 end loop; 234 235 if RS (RS'Last).High /= Wide_Character'Last then 236 N := N + 1; 237 Result (N).Low := Wide_Character'Succ (RS (RS'Last).High); 238 Result (N).High := Wide_Character'Last; 239 end if; 240 end if; 241 242 return (AF.Controlled with 243 Set => new Wide_Character_Ranges'(Result (1 .. N))); 244 end "not"; 245 246 ---------- 247 -- "or" -- 248 ---------- 249 250 function "or" 251 (Left, Right : Wide_Character_Set) return Wide_Character_Set 252 is 253 LS : constant Wide_Character_Ranges_Access := Left.Set; 254 RS : constant Wide_Character_Ranges_Access := Right.Set; 255 256 Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); 257 N : Natural; 258 L, R : Natural; 259 260 begin 261 N := 0; 262 L := 1; 263 R := 1; 264 265 -- Loop through ranges in output file 266 267 loop 268 -- If no left ranges left, copy next right range 269 270 if L > LS'Last then 271 exit when R > RS'Last; 272 N := N + 1; 273 Result (N) := RS (R); 274 R := R + 1; 275 276 -- If no right ranges left, copy next left range 277 278 elsif R > RS'Last then 279 N := N + 1; 280 Result (N) := LS (L); 281 L := L + 1; 282 283 else 284 -- We have two ranges, choose lower one 285 286 N := N + 1; 287 288 if LS (L).Low <= RS (R).Low then 289 Result (N) := LS (L); 290 L := L + 1; 291 else 292 Result (N) := RS (R); 293 R := R + 1; 294 end if; 295 296 -- Loop to collapse ranges into last range 297 298 loop 299 -- Collapse next length range into current result range 300 -- if possible. 301 302 if L <= LS'Last 303 and then LS (L).Low <= Wide_Character'Succ (Result (N).High) 304 then 305 Result (N).High := 306 Wide_Character'Max (Result (N).High, LS (L).High); 307 L := L + 1; 308 309 -- Collapse next right range into current result range 310 -- if possible 311 312 elsif R <= RS'Last 313 and then RS (R).Low <= 314 Wide_Character'Succ (Result (N).High) 315 then 316 Result (N).High := 317 Wide_Character'Max (Result (N).High, RS (R).High); 318 R := R + 1; 319 320 -- If neither range collapses, then done with this range 321 322 else 323 exit; 324 end if; 325 end loop; 326 end if; 327 end loop; 328 329 return (AF.Controlled with 330 Set => new Wide_Character_Ranges'(Result (1 .. N))); 331 end "or"; 332 333 ----------- 334 -- "xor" -- 335 ----------- 336 337 function "xor" 338 (Left, Right : Wide_Character_Set) return Wide_Character_Set 339 is 340 begin 341 return (Left or Right) - (Left and Right); 342 end "xor"; 343 344 ------------ 345 -- Adjust -- 346 ------------ 347 348 procedure Adjust (Object : in out Wide_Character_Mapping) is 349 begin 350 Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all); 351 end Adjust; 352 353 procedure Adjust (Object : in out Wide_Character_Set) is 354 begin 355 Object.Set := new Wide_Character_Ranges'(Object.Set.all); 356 end Adjust; 357 358 -------------- 359 -- Finalize -- 360 -------------- 361 362 procedure Finalize (Object : in out Wide_Character_Mapping) is 363 364 procedure Free is new Ada.Unchecked_Deallocation 365 (Wide_Character_Mapping_Values, 366 Wide_Character_Mapping_Values_Access); 367 368 begin 369 if Object.Map /= Null_Map'Unrestricted_Access then 370 Free (Object.Map); 371 end if; 372 end Finalize; 373 374 procedure Finalize (Object : in out Wide_Character_Set) is 375 376 procedure Free is new Ada.Unchecked_Deallocation 377 (Wide_Character_Ranges, 378 Wide_Character_Ranges_Access); 379 380 begin 381 if Object.Set /= Null_Range'Unrestricted_Access then 382 Free (Object.Set); 383 end if; 384 end Finalize; 385 386 ---------------- 387 -- Initialize -- 388 ---------------- 389 390 procedure Initialize (Object : in out Wide_Character_Mapping) is 391 begin 392 Object := Identity; 393 end Initialize; 394 395 procedure Initialize (Object : in out Wide_Character_Set) is 396 begin 397 Object := Null_Set; 398 end Initialize; 399 400 ----------- 401 -- Is_In -- 402 ----------- 403 404 function Is_In 405 (Element : Wide_Character; 406 Set : Wide_Character_Set) return Boolean 407 is 408 L, R, M : Natural; 409 SS : constant Wide_Character_Ranges_Access := Set.Set; 410 411 begin 412 L := 1; 413 R := SS'Last; 414 415 -- Binary search loop. The invariant is that if Element is in any of 416 -- of the constituent ranges it is in one between Set (L) and Set (R). 417 418 loop 419 if L > R then 420 return False; 421 422 else 423 M := (L + R) / 2; 424 425 if Element > SS (M).High then 426 L := M + 1; 427 elsif Element < SS (M).Low then 428 R := M - 1; 429 else 430 return True; 431 end if; 432 end if; 433 end loop; 434 end Is_In; 435 436 --------------- 437 -- Is_Subset -- 438 --------------- 439 440 function Is_Subset 441 (Elements : Wide_Character_Set; 442 Set : Wide_Character_Set) return Boolean 443 is 444 ES : constant Wide_Character_Ranges_Access := Elements.Set; 445 SS : constant Wide_Character_Ranges_Access := Set.Set; 446 447 S : Positive := 1; 448 E : Positive := 1; 449 450 begin 451 loop 452 -- If no more element ranges, done, and result is true 453 454 if E > ES'Last then 455 return True; 456 457 -- If more element ranges, but no more set ranges, result is false 458 459 elsif S > SS'Last then 460 return False; 461 462 -- Remove irrelevant set range 463 464 elsif SS (S).High < ES (E).Low then 465 S := S + 1; 466 467 -- Get rid of element range that is properly covered by set 468 469 elsif SS (S).Low <= ES (E).Low 470 and then ES (E).High <= SS (S).High 471 then 472 E := E + 1; 473 474 -- Otherwise we have a non-covered element range, result is false 475 476 else 477 return False; 478 end if; 479 end loop; 480 end Is_Subset; 481 482 --------------- 483 -- To_Domain -- 484 --------------- 485 486 function To_Domain 487 (Map : Wide_Character_Mapping) return Wide_Character_Sequence 488 is 489 begin 490 return Map.Map.Domain; 491 end To_Domain; 492 493 ---------------- 494 -- To_Mapping -- 495 ---------------- 496 497 function To_Mapping 498 (From, To : Wide_Character_Sequence) return Wide_Character_Mapping 499 is 500 Domain : Wide_Character_Sequence (1 .. From'Length); 501 Rangev : Wide_Character_Sequence (1 .. To'Length); 502 N : Natural := 0; 503 504 begin 505 if From'Length /= To'Length then 506 raise Translation_Error; 507 508 else 509 pragma Warnings (Off); -- apparent uninit use of Domain 510 511 for J in From'Range loop 512 for M in 1 .. N loop 513 if From (J) = Domain (M) then 514 raise Translation_Error; 515 elsif From (J) < Domain (M) then 516 Domain (M + 1 .. N + 1) := Domain (M .. N); 517 Rangev (M + 1 .. N + 1) := Rangev (M .. N); 518 Domain (M) := From (J); 519 Rangev (M) := To (J); 520 goto Continue; 521 end if; 522 end loop; 523 524 Domain (N + 1) := From (J); 525 Rangev (N + 1) := To (J); 526 527 <<Continue>> 528 N := N + 1; 529 end loop; 530 531 pragma Warnings (On); 532 533 return (AF.Controlled with 534 Map => new Wide_Character_Mapping_Values'( 535 Length => N, 536 Domain => Domain (1 .. N), 537 Rangev => Rangev (1 .. N))); 538 end if; 539 end To_Mapping; 540 541 -------------- 542 -- To_Range -- 543 -------------- 544 545 function To_Range 546 (Map : Wide_Character_Mapping) return Wide_Character_Sequence 547 is 548 begin 549 return Map.Map.Rangev; 550 end To_Range; 551 552 --------------- 553 -- To_Ranges -- 554 --------------- 555 556 function To_Ranges 557 (Set : Wide_Character_Set) return Wide_Character_Ranges 558 is 559 begin 560 return Set.Set.all; 561 end To_Ranges; 562 563 ----------------- 564 -- To_Sequence -- 565 ----------------- 566 567 function To_Sequence 568 (Set : Wide_Character_Set) return Wide_Character_Sequence 569 is 570 SS : constant Wide_Character_Ranges_Access := Set.Set; 571 N : Natural := 0; 572 Count : Natural := 0; 573 574 begin 575 for J in SS'Range loop 576 Count := 577 Count + (Wide_Character'Pos (SS (J).High) - 578 Wide_Character'Pos (SS (J).Low) + 1); 579 end loop; 580 581 return Result : Wide_String (1 .. Count) do 582 for J in SS'Range loop 583 for K in SS (J).Low .. SS (J).High loop 584 N := N + 1; 585 Result (N) := K; 586 end loop; 587 end loop; 588 end return; 589 end To_Sequence; 590 591 ------------ 592 -- To_Set -- 593 ------------ 594 595 -- Case of multiple range input 596 597 function To_Set 598 (Ranges : Wide_Character_Ranges) return Wide_Character_Set 599 is 600 Result : Wide_Character_Ranges (Ranges'Range); 601 N : Natural := 0; 602 J : Natural; 603 604 begin 605 -- The output of To_Set is required to be sorted by increasing Low 606 -- values, and discontiguous, so first we sort them as we enter them, 607 -- using a simple insertion sort. 608 609 pragma Warnings (Off); 610 -- Kill bogus warning on Result being uninitialized 611 612 for J in Ranges'Range loop 613 for K in 1 .. N loop 614 if Ranges (J).Low < Result (K).Low then 615 Result (K + 1 .. N + 1) := Result (K .. N); 616 Result (K) := Ranges (J); 617 goto Continue; 618 end if; 619 end loop; 620 621 Result (N + 1) := Ranges (J); 622 623 <<Continue>> 624 N := N + 1; 625 end loop; 626 627 pragma Warnings (On); 628 629 -- Now collapse any contiguous or overlapping ranges 630 631 J := 1; 632 while J < N loop 633 if Result (J).High < Result (J).Low then 634 N := N - 1; 635 Result (J .. N) := Result (J + 1 .. N + 1); 636 637 elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then 638 Result (J).High := 639 Wide_Character'Max (Result (J).High, Result (J + 1).High); 640 641 N := N - 1; 642 Result (J + 1 .. N) := Result (J + 2 .. N + 1); 643 644 else 645 J := J + 1; 646 end if; 647 end loop; 648 649 if N > 0 and then Result (N).High < Result (N).Low then 650 N := N - 1; 651 end if; 652 653 return (AF.Controlled with 654 Set => new Wide_Character_Ranges'(Result (1 .. N))); 655 end To_Set; 656 657 -- Case of single range input 658 659 function To_Set 660 (Span : Wide_Character_Range) return Wide_Character_Set 661 is 662 begin 663 if Span.Low > Span.High then 664 return Null_Set; 665 -- This is safe, because there is no procedure with parameter 666 -- Wide_Character_Set of mode "out" or "in out". 667 668 else 669 return (AF.Controlled with 670 Set => new Wide_Character_Ranges'(1 => Span)); 671 end if; 672 end To_Set; 673 674 -- Case of wide string input 675 676 function To_Set 677 (Sequence : Wide_Character_Sequence) return Wide_Character_Set 678 is 679 R : Wide_Character_Ranges (1 .. Sequence'Length); 680 681 begin 682 for J in R'Range loop 683 R (J) := (Sequence (J), Sequence (J)); 684 end loop; 685 686 return To_Set (R); 687 end To_Set; 688 689 -- Case of single wide character input 690 691 function To_Set 692 (Singleton : Wide_Character) return Wide_Character_Set 693 is 694 begin 695 return 696 (AF.Controlled with 697 Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton))); 698 end To_Set; 699 700 ----------- 701 -- Value -- 702 ----------- 703 704 function Value 705 (Map : Wide_Character_Mapping; 706 Element : Wide_Character) return Wide_Character 707 is 708 L, R, M : Natural; 709 710 MV : constant Wide_Character_Mapping_Values_Access := Map.Map; 711 712 begin 713 L := 1; 714 R := MV.Domain'Last; 715 716 -- Binary search loop 717 718 loop 719 -- If not found, identity 720 721 if L > R then 722 return Element; 723 724 -- Otherwise do binary divide 725 726 else 727 M := (L + R) / 2; 728 729 if Element < MV.Domain (M) then 730 R := M - 1; 731 732 elsif Element > MV.Domain (M) then 733 L := M + 1; 734 735 else -- Element = MV.Domain (M) then 736 return MV.Rangev (M); 737 end if; 738 end if; 739 end loop; 740 end Value; 741 742end Ada.Strings.Wide_Maps; 743