1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S T R I N G S . W I D E _ 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_Wide_Maps is 35 36 --------- 37 -- "-" -- 38 --------- 39 40 function "-" 41 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set 42 is 43 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; 44 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; 45 46 Result : Wide_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_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 of 71 -- 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_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_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_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_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_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_Wide_Character_Set) return Wide_Wide_Character_Set 160 is 161 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; 162 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; 163 164 Result : Wide_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 := 186 Wide_Wide_Character'Max (LS (L).Low, RS (R).Low); 187 Result (N).High := 188 Wide_Wide_Character'Min (LS (L).High, RS (R).High); 189 190 if RS (R).High = LS (L).High then 191 L := L + 1; 192 R := R + 1; 193 elsif RS (R).High < LS (L).High then 194 R := R + 1; 195 else 196 L := L + 1; 197 end if; 198 end if; 199 end loop; 200 201 return (AF.Controlled with 202 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); 203 end "and"; 204 205 ----------- 206 -- "not" -- 207 ----------- 208 209 function "not" 210 (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set 211 is 212 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; 213 214 Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1); 215 N : Natural := 0; 216 217 begin 218 if RS'Last = 0 then 219 N := 1; 220 Result (1) := (Low => Wide_Wide_Character'First, 221 High => Wide_Wide_Character'Last); 222 223 else 224 if RS (1).Low /= Wide_Wide_Character'First then 225 N := N + 1; 226 Result (N).Low := Wide_Wide_Character'First; 227 Result (N).High := Wide_Wide_Character'Pred (RS (1).Low); 228 end if; 229 230 for K in 1 .. RS'Last - 1 loop 231 N := N + 1; 232 Result (N).Low := Wide_Wide_Character'Succ (RS (K).High); 233 Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low); 234 end loop; 235 236 if RS (RS'Last).High /= Wide_Wide_Character'Last then 237 N := N + 1; 238 Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High); 239 Result (N).High := Wide_Wide_Character'Last; 240 end if; 241 end if; 242 243 return (AF.Controlled with 244 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); 245 end "not"; 246 247 ---------- 248 -- "or" -- 249 ---------- 250 251 function "or" 252 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set 253 is 254 LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; 255 RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; 256 257 Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); 258 N : Natural; 259 L, R : Natural; 260 261 begin 262 N := 0; 263 L := 1; 264 R := 1; 265 266 -- Loop through ranges in output file 267 268 loop 269 -- If no left ranges left, copy next right range 270 271 if L > LS'Last then 272 exit when R > RS'Last; 273 N := N + 1; 274 Result (N) := RS (R); 275 R := R + 1; 276 277 -- If no right ranges left, copy next left range 278 279 elsif R > RS'Last then 280 N := N + 1; 281 Result (N) := LS (L); 282 L := L + 1; 283 284 else 285 -- We have two ranges, choose lower one 286 287 N := N + 1; 288 289 if LS (L).Low <= RS (R).Low then 290 Result (N) := LS (L); 291 L := L + 1; 292 else 293 Result (N) := RS (R); 294 R := R + 1; 295 end if; 296 297 -- Loop to collapse ranges into last range 298 299 loop 300 -- Collapse next length range into current result range 301 -- if possible. 302 303 if L <= LS'Last 304 and then LS (L).Low <= 305 Wide_Wide_Character'Succ (Result (N).High) 306 then 307 Result (N).High := 308 Wide_Wide_Character'Max (Result (N).High, LS (L).High); 309 L := L + 1; 310 311 -- Collapse next right range into current result range 312 -- if possible 313 314 elsif R <= RS'Last 315 and then RS (R).Low <= 316 Wide_Wide_Character'Succ (Result (N).High) 317 then 318 Result (N).High := 319 Wide_Wide_Character'Max (Result (N).High, RS (R).High); 320 R := R + 1; 321 322 -- If neither range collapses, then done with this range 323 324 else 325 exit; 326 end if; 327 end loop; 328 end if; 329 end loop; 330 331 return (AF.Controlled with 332 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); 333 end "or"; 334 335 ----------- 336 -- "xor" -- 337 ----------- 338 339 function "xor" 340 (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set 341 is 342 begin 343 return (Left or Right) - (Left and Right); 344 end "xor"; 345 346 ------------ 347 -- Adjust -- 348 ------------ 349 350 procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is 351 begin 352 Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all); 353 end Adjust; 354 355 procedure Adjust (Object : in out Wide_Wide_Character_Set) is 356 begin 357 Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all); 358 end Adjust; 359 360 -------------- 361 -- Finalize -- 362 -------------- 363 364 procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is 365 366 procedure Free is new Ada.Unchecked_Deallocation 367 (Wide_Wide_Character_Mapping_Values, 368 Wide_Wide_Character_Mapping_Values_Access); 369 370 begin 371 if Object.Map /= Null_Map'Unrestricted_Access then 372 Free (Object.Map); 373 end if; 374 end Finalize; 375 376 procedure Finalize (Object : in out Wide_Wide_Character_Set) is 377 378 procedure Free is new Ada.Unchecked_Deallocation 379 (Wide_Wide_Character_Ranges, 380 Wide_Wide_Character_Ranges_Access); 381 382 begin 383 if Object.Set /= Null_Range'Unrestricted_Access then 384 Free (Object.Set); 385 end if; 386 end Finalize; 387 388 ---------------- 389 -- Initialize -- 390 ---------------- 391 392 procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is 393 begin 394 Object := Identity; 395 end Initialize; 396 397 procedure Initialize (Object : in out Wide_Wide_Character_Set) is 398 begin 399 Object := Null_Set; 400 end Initialize; 401 402 ----------- 403 -- Is_In -- 404 ----------- 405 406 function Is_In 407 (Element : Wide_Wide_Character; 408 Set : Wide_Wide_Character_Set) return Boolean 409 is 410 L, R, M : Natural; 411 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; 412 413 begin 414 L := 1; 415 R := SS'Last; 416 417 -- Binary search loop. The invariant is that if Element is in any of 418 -- of the constituent ranges it is in one between Set (L) and Set (R). 419 420 loop 421 if L > R then 422 return False; 423 424 else 425 M := (L + R) / 2; 426 427 if Element > SS (M).High then 428 L := M + 1; 429 elsif Element < SS (M).Low then 430 R := M - 1; 431 else 432 return True; 433 end if; 434 end if; 435 end loop; 436 end Is_In; 437 438 --------------- 439 -- Is_Subset -- 440 --------------- 441 442 function Is_Subset 443 (Elements : Wide_Wide_Character_Set; 444 Set : Wide_Wide_Character_Set) return Boolean 445 is 446 ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set; 447 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; 448 449 S : Positive := 1; 450 E : Positive := 1; 451 452 begin 453 loop 454 -- If no more element ranges, done, and result is true 455 456 if E > ES'Last then 457 return True; 458 459 -- If more element ranges, but no more set ranges, result is false 460 461 elsif S > SS'Last then 462 return False; 463 464 -- Remove irrelevant set range 465 466 elsif SS (S).High < ES (E).Low then 467 S := S + 1; 468 469 -- Get rid of element range that is properly covered by set 470 471 elsif SS (S).Low <= ES (E).Low 472 and then ES (E).High <= SS (S).High 473 then 474 E := E + 1; 475 476 -- Otherwise we have a non-covered element range, result is false 477 478 else 479 return False; 480 end if; 481 end loop; 482 end Is_Subset; 483 484 --------------- 485 -- To_Domain -- 486 --------------- 487 488 function To_Domain 489 (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence 490 is 491 begin 492 return Map.Map.Domain; 493 end To_Domain; 494 495 ---------------- 496 -- To_Mapping -- 497 ---------------- 498 499 function To_Mapping 500 (From, To : Wide_Wide_Character_Sequence) 501 return Wide_Wide_Character_Mapping 502 is 503 Domain : Wide_Wide_Character_Sequence (1 .. From'Length); 504 Rangev : Wide_Wide_Character_Sequence (1 .. To'Length); 505 N : Natural := 0; 506 507 begin 508 if From'Length /= To'Length then 509 raise Translation_Error; 510 511 else 512 pragma Warnings (Off); -- apparent uninit use of Domain 513 514 for J in From'Range loop 515 for M in 1 .. N loop 516 if From (J) = Domain (M) then 517 raise Translation_Error; 518 elsif From (J) < Domain (M) then 519 Domain (M + 1 .. N + 1) := Domain (M .. N); 520 Rangev (M + 1 .. N + 1) := Rangev (M .. N); 521 Domain (M) := From (J); 522 Rangev (M) := To (J); 523 goto Continue; 524 end if; 525 end loop; 526 527 Domain (N + 1) := From (J); 528 Rangev (N + 1) := To (J); 529 530 <<Continue>> 531 N := N + 1; 532 end loop; 533 534 pragma Warnings (On); 535 536 return (AF.Controlled with 537 Map => new Wide_Wide_Character_Mapping_Values'( 538 Length => N, 539 Domain => Domain (1 .. N), 540 Rangev => Rangev (1 .. N))); 541 end if; 542 end To_Mapping; 543 544 -------------- 545 -- To_Range -- 546 -------------- 547 548 function To_Range 549 (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence 550 is 551 begin 552 return Map.Map.Rangev; 553 end To_Range; 554 555 --------------- 556 -- To_Ranges -- 557 --------------- 558 559 function To_Ranges 560 (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges 561 is 562 begin 563 return Set.Set.all; 564 end To_Ranges; 565 566 ----------------- 567 -- To_Sequence -- 568 ----------------- 569 570 function To_Sequence 571 (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence 572 is 573 SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; 574 N : Natural := 0; 575 Count : Natural := 0; 576 577 begin 578 for J in SS'Range loop 579 Count := 580 Count + (Wide_Wide_Character'Pos (SS (J).High) - 581 Wide_Wide_Character'Pos (SS (J).Low) + 1); 582 end loop; 583 584 return Result : Wide_Wide_String (1 .. Count) do 585 for J in SS'Range loop 586 for K in SS (J).Low .. SS (J).High loop 587 N := N + 1; 588 Result (N) := K; 589 end loop; 590 end loop; 591 end return; 592 end To_Sequence; 593 594 ------------ 595 -- To_Set -- 596 ------------ 597 598 -- Case of multiple range input 599 600 function To_Set 601 (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set 602 is 603 Result : Wide_Wide_Character_Ranges (Ranges'Range); 604 N : Natural := 0; 605 J : Natural; 606 607 begin 608 -- The output of To_Set is required to be sorted by increasing Low 609 -- values, and discontiguous, so first we sort them as we enter them, 610 -- using a simple insertion sort. 611 612 pragma Warnings (Off); 613 -- Kill bogus warning on Result being uninitialized 614 615 for J in Ranges'Range loop 616 for K in 1 .. N loop 617 if Ranges (J).Low < Result (K).Low then 618 Result (K + 1 .. N + 1) := Result (K .. N); 619 Result (K) := Ranges (J); 620 goto Continue; 621 end if; 622 end loop; 623 624 Result (N + 1) := Ranges (J); 625 626 <<Continue>> 627 N := N + 1; 628 end loop; 629 630 pragma Warnings (On); 631 632 -- Now collapse any contiguous or overlapping ranges 633 634 J := 1; 635 while J < N loop 636 if Result (J).High < Result (J).Low then 637 N := N - 1; 638 Result (J .. N) := Result (J + 1 .. N + 1); 639 640 elsif Wide_Wide_Character'Succ (Result (J).High) >= 641 Result (J + 1).Low 642 then 643 Result (J).High := 644 Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High); 645 646 N := N - 1; 647 Result (J + 1 .. N) := Result (J + 2 .. N + 1); 648 649 else 650 J := J + 1; 651 end if; 652 end loop; 653 654 if Result (N).High < Result (N).Low then 655 N := N - 1; 656 end if; 657 658 return (AF.Controlled with 659 Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); 660 end To_Set; 661 662 -- Case of single range input 663 664 function To_Set 665 (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set 666 is 667 begin 668 if Span.Low > Span.High then 669 return Null_Set; 670 -- This is safe, because there is no procedure with parameter 671 -- Wide_Wide_Character_Set of mode "out" or "in out". 672 673 else 674 return (AF.Controlled with 675 Set => new Wide_Wide_Character_Ranges'(1 => Span)); 676 end if; 677 end To_Set; 678 679 -- Case of wide string input 680 681 function To_Set 682 (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set 683 is 684 R : Wide_Wide_Character_Ranges (1 .. Sequence'Length); 685 686 begin 687 for J in R'Range loop 688 R (J) := (Sequence (J), Sequence (J)); 689 end loop; 690 691 return To_Set (R); 692 end To_Set; 693 694 -- Case of single wide character input 695 696 function To_Set 697 (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set 698 is 699 begin 700 return 701 (AF.Controlled with 702 Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton))); 703 end To_Set; 704 705 ----------- 706 -- Value -- 707 ----------- 708 709 function Value 710 (Map : Wide_Wide_Character_Mapping; 711 Element : Wide_Wide_Character) return Wide_Wide_Character 712 is 713 L, R, M : Natural; 714 715 MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map; 716 717 begin 718 L := 1; 719 R := MV.Domain'Last; 720 721 -- Binary search loop 722 723 loop 724 -- If not found, identity 725 726 if L > R then 727 return Element; 728 729 -- Otherwise do binary divide 730 731 else 732 M := (L + R) / 2; 733 734 if Element < MV.Domain (M) then 735 R := M - 1; 736 737 elsif Element > MV.Domain (M) then 738 L := M + 1; 739 740 else -- Element = MV.Domain (M) then 741 return MV.Rangev (M); 742 end if; 743 end if; 744 end loop; 745 end Value; 746 747end Ada.Strings.Wide_Wide_Maps; 748