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