1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . S T R I N G S . F I X E D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 32-- Note: This code is derived from the ADAR.CSH public domain Ada 83 versions 33-- of the Appendix C string handling packages. One change is to avoid the use 34-- of Is_In, so that we are not dependent on inlining. Note that the search 35-- function implementations are to be found in the auxiliary package 36-- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR 37-- used a subunit for this procedure). The number of errors having to do with 38-- bounds of function return results were also fixed, and use of & removed for 39-- efficiency reasons. 40 41with Ada.Strings.Maps; use Ada.Strings.Maps; 42with Ada.Strings.Search; 43 44package body Ada.Strings.Fixed is 45 46 ------------------------ 47 -- Search Subprograms -- 48 ------------------------ 49 50 function Index 51 (Source : String; 52 Pattern : String; 53 Going : Direction := Forward; 54 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural 55 renames Ada.Strings.Search.Index; 56 57 function Index 58 (Source : String; 59 Pattern : String; 60 Going : Direction := Forward; 61 Mapping : Maps.Character_Mapping_Function) return Natural 62 renames Ada.Strings.Search.Index; 63 64 function Index 65 (Source : String; 66 Set : Maps.Character_Set; 67 Test : Membership := Inside; 68 Going : Direction := Forward) return Natural 69 renames Ada.Strings.Search.Index; 70 71 function Index 72 (Source : String; 73 Pattern : String; 74 From : Positive; 75 Going : Direction := Forward; 76 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural 77 renames Ada.Strings.Search.Index; 78 79 function Index 80 (Source : String; 81 Pattern : String; 82 From : Positive; 83 Going : Direction := Forward; 84 Mapping : Maps.Character_Mapping_Function) return Natural 85 renames Ada.Strings.Search.Index; 86 87 function Index 88 (Source : String; 89 Set : Maps.Character_Set; 90 From : Positive; 91 Test : Membership := Inside; 92 Going : Direction := Forward) return Natural 93 renames Ada.Strings.Search.Index; 94 95 function Index_Non_Blank 96 (Source : String; 97 Going : Direction := Forward) return Natural 98 renames Ada.Strings.Search.Index_Non_Blank; 99 100 function Index_Non_Blank 101 (Source : String; 102 From : Positive; 103 Going : Direction := Forward) return Natural 104 renames Ada.Strings.Search.Index_Non_Blank; 105 106 function Count 107 (Source : String; 108 Pattern : String; 109 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural 110 renames Ada.Strings.Search.Count; 111 112 function Count 113 (Source : String; 114 Pattern : String; 115 Mapping : Maps.Character_Mapping_Function) return Natural 116 renames Ada.Strings.Search.Count; 117 118 function Count 119 (Source : String; 120 Set : Maps.Character_Set) return Natural 121 renames Ada.Strings.Search.Count; 122 123 procedure Find_Token 124 (Source : String; 125 Set : Maps.Character_Set; 126 From : Positive; 127 Test : Membership; 128 First : out Positive; 129 Last : out Natural) 130 renames Ada.Strings.Search.Find_Token; 131 132 procedure Find_Token 133 (Source : String; 134 Set : Maps.Character_Set; 135 Test : Membership; 136 First : out Positive; 137 Last : out Natural) 138 renames Ada.Strings.Search.Find_Token; 139 140 --------- 141 -- "*" -- 142 --------- 143 144 function "*" 145 (Left : Natural; 146 Right : Character) return String 147 is 148 Result : String (1 .. Left); 149 150 begin 151 for J in Result'Range loop 152 Result (J) := Right; 153 end loop; 154 155 return Result; 156 end "*"; 157 158 function "*" 159 (Left : Natural; 160 Right : String) return String 161 is 162 Result : String (1 .. Left * Right'Length); 163 Ptr : Integer := 1; 164 165 begin 166 for J in 1 .. Left loop 167 Result (Ptr .. Ptr + Right'Length - 1) := Right; 168 Ptr := Ptr + Right'Length; 169 end loop; 170 171 return Result; 172 end "*"; 173 174 ------------ 175 -- Delete -- 176 ------------ 177 178 function Delete 179 (Source : String; 180 From : Positive; 181 Through : Natural) return String 182 is 183 begin 184 if From > Through then 185 declare 186 subtype Result_Type is String (1 .. Source'Length); 187 188 begin 189 return Result_Type (Source); 190 end; 191 192 elsif From not in Source'Range 193 or else Through > Source'Last 194 then 195 pragma Annotate 196 (CodePeer, False_Positive, 197 "test always false", "self fullfilling prophecy"); 198 199 -- In most cases this raises an exception, but the case of deleting 200 -- a null string at the end of the current one is a special-case, and 201 -- reflects the equivalence with Replace_String (RM A.4.3 (86/3)). 202 203 if From = Source'Last + 1 and then From = Through then 204 return Source; 205 else 206 raise Index_Error; 207 end if; 208 209 else 210 declare 211 Front : constant Integer := From - Source'First; 212 Result : String (1 .. Source'Length - (Through - From + 1)); 213 214 begin 215 Result (1 .. Front) := 216 Source (Source'First .. From - 1); 217 Result (Front + 1 .. Result'Last) := 218 Source (Through + 1 .. Source'Last); 219 220 return Result; 221 end; 222 end if; 223 end Delete; 224 225 procedure Delete 226 (Source : in out String; 227 From : Positive; 228 Through : Natural; 229 Justify : Alignment := Left; 230 Pad : Character := Space) 231 is 232 begin 233 Move (Source => Delete (Source, From, Through), 234 Target => Source, 235 Justify => Justify, 236 Pad => Pad); 237 end Delete; 238 239 ---------- 240 -- Head -- 241 ---------- 242 243 function Head 244 (Source : String; 245 Count : Natural; 246 Pad : Character := Space) return String 247 is 248 subtype Result_Type is String (1 .. Count); 249 250 begin 251 if Count < Source'Length then 252 return 253 Result_Type (Source (Source'First .. Source'First + Count - 1)); 254 255 else 256 declare 257 Result : Result_Type; 258 259 begin 260 Result (1 .. Source'Length) := Source; 261 262 for J in Source'Length + 1 .. Count loop 263 Result (J) := Pad; 264 end loop; 265 266 return Result; 267 end; 268 end if; 269 end Head; 270 271 procedure Head 272 (Source : in out String; 273 Count : Natural; 274 Justify : Alignment := Left; 275 Pad : Character := Space) 276 is 277 begin 278 Move (Source => Head (Source, Count, Pad), 279 Target => Source, 280 Drop => Error, 281 Justify => Justify, 282 Pad => Pad); 283 end Head; 284 285 ------------ 286 -- Insert -- 287 ------------ 288 289 function Insert 290 (Source : String; 291 Before : Positive; 292 New_Item : String) return String 293 is 294 Result : String (1 .. Source'Length + New_Item'Length); 295 Front : constant Integer := Before - Source'First; 296 297 begin 298 if Before not in Source'First .. Source'Last + 1 then 299 raise Index_Error; 300 end if; 301 302 Result (1 .. Front) := 303 Source (Source'First .. Before - 1); 304 Result (Front + 1 .. Front + New_Item'Length) := 305 New_Item; 306 Result (Front + New_Item'Length + 1 .. Result'Last) := 307 Source (Before .. Source'Last); 308 309 return Result; 310 end Insert; 311 312 procedure Insert 313 (Source : in out String; 314 Before : Positive; 315 New_Item : String; 316 Drop : Truncation := Error) 317 is 318 begin 319 Move (Source => Insert (Source, Before, New_Item), 320 Target => Source, 321 Drop => Drop); 322 end Insert; 323 324 ---------- 325 -- Move -- 326 ---------- 327 328 procedure Move 329 (Source : String; 330 Target : out String; 331 Drop : Truncation := Error; 332 Justify : Alignment := Left; 333 Pad : Character := Space) 334 is 335 Sfirst : constant Integer := Source'First; 336 Slast : constant Integer := Source'Last; 337 Slength : constant Integer := Source'Length; 338 339 Tfirst : constant Integer := Target'First; 340 Tlast : constant Integer := Target'Last; 341 Tlength : constant Integer := Target'Length; 342 343 function Is_Padding (Item : String) return Boolean; 344 -- Check if Item is all Pad characters, return True if so, False if not 345 346 function Is_Padding (Item : String) return Boolean is 347 begin 348 for J in Item'Range loop 349 if Item (J) /= Pad then 350 return False; 351 end if; 352 end loop; 353 354 return True; 355 end Is_Padding; 356 357 -- Start of processing for Move 358 359 begin 360 if Slength = Tlength then 361 Target := Source; 362 363 elsif Slength > Tlength then 364 case Drop is 365 when Left => 366 Target := Source (Slast - Tlength + 1 .. Slast); 367 368 when Right => 369 Target := Source (Sfirst .. Sfirst + Tlength - 1); 370 371 when Error => 372 case Justify is 373 when Left => 374 if Is_Padding (Source (Sfirst + Tlength .. Slast)) then 375 Target := 376 Source (Sfirst .. Sfirst + Target'Length - 1); 377 else 378 raise Length_Error; 379 end if; 380 381 when Right => 382 if Is_Padding (Source (Sfirst .. Slast - Tlength)) then 383 Target := Source (Slast - Tlength + 1 .. Slast); 384 else 385 raise Length_Error; 386 end if; 387 388 when Center => 389 raise Length_Error; 390 end case; 391 end case; 392 393 -- Source'Length < Target'Length 394 395 else 396 case Justify is 397 when Left => 398 Target (Tfirst .. Tfirst + Slength - 1) := Source; 399 400 for I in Tfirst + Slength .. Tlast loop 401 Target (I) := Pad; 402 end loop; 403 404 when Right => 405 for I in Tfirst .. Tlast - Slength loop 406 Target (I) := Pad; 407 end loop; 408 409 Target (Tlast - Slength + 1 .. Tlast) := Source; 410 411 when Center => 412 declare 413 Front_Pad : constant Integer := (Tlength - Slength) / 2; 414 Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; 415 416 begin 417 for I in Tfirst .. Tfirst_Fpad - 1 loop 418 Target (I) := Pad; 419 end loop; 420 421 Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; 422 423 for I in Tfirst_Fpad + Slength .. Tlast loop 424 Target (I) := Pad; 425 end loop; 426 end; 427 end case; 428 end if; 429 end Move; 430 431 --------------- 432 -- Overwrite -- 433 --------------- 434 435 function Overwrite 436 (Source : String; 437 Position : Positive; 438 New_Item : String) return String 439 is 440 begin 441 if Position not in Source'First .. Source'Last + 1 then 442 raise Index_Error; 443 end if; 444 445 declare 446 Result_Length : constant Natural := 447 Integer'Max 448 (Source'Length, 449 Position - Source'First + New_Item'Length); 450 451 Result : String (1 .. Result_Length); 452 Front : constant Integer := Position - Source'First; 453 454 begin 455 Result (1 .. Front) := 456 Source (Source'First .. Position - 1); 457 Result (Front + 1 .. Front + New_Item'Length) := 458 New_Item; 459 Result (Front + New_Item'Length + 1 .. Result'Length) := 460 Source (Position + New_Item'Length .. Source'Last); 461 return Result; 462 end; 463 end Overwrite; 464 465 procedure Overwrite 466 (Source : in out String; 467 Position : Positive; 468 New_Item : String; 469 Drop : Truncation := Right) 470 is 471 begin 472 Move (Source => Overwrite (Source, Position, New_Item), 473 Target => Source, 474 Drop => Drop); 475 end Overwrite; 476 477 ------------------- 478 -- Replace_Slice -- 479 ------------------- 480 481 function Replace_Slice 482 (Source : String; 483 Low : Positive; 484 High : Natural; 485 By : String) return String 486 is 487 begin 488 if Low > Source'Last + 1 or else High < Source'First - 1 then 489 raise Index_Error; 490 end if; 491 492 if High >= Low then 493 declare 494 Front_Len : constant Integer := 495 Integer'Max (0, Low - Source'First); 496 -- Length of prefix of Source copied to result 497 498 Back_Len : constant Integer := 499 Integer'Max (0, Source'Last - High); 500 -- Length of suffix of Source copied to result 501 502 Result_Length : constant Integer := 503 Front_Len + By'Length + Back_Len; 504 -- Length of result 505 506 Result : String (1 .. Result_Length); 507 508 begin 509 Result (1 .. Front_Len) := Source (Source'First .. Low - 1); 510 Result (Front_Len + 1 .. Front_Len + By'Length) := By; 511 Result (Front_Len + By'Length + 1 .. Result'Length) := 512 Source (High + 1 .. Source'Last); 513 return Result; 514 end; 515 516 else 517 return Insert (Source, Before => Low, New_Item => By); 518 end if; 519 end Replace_Slice; 520 521 procedure Replace_Slice 522 (Source : in out String; 523 Low : Positive; 524 High : Natural; 525 By : String; 526 Drop : Truncation := Error; 527 Justify : Alignment := Left; 528 Pad : Character := Space) 529 is 530 begin 531 Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); 532 end Replace_Slice; 533 534 ---------- 535 -- Tail -- 536 ---------- 537 538 function Tail 539 (Source : String; 540 Count : Natural; 541 Pad : Character := Space) return String 542 is 543 subtype Result_Type is String (1 .. Count); 544 545 begin 546 if Count < Source'Length then 547 return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); 548 549 -- Pad on left 550 551 else 552 declare 553 Result : Result_Type; 554 555 begin 556 for J in 1 .. Count - Source'Length loop 557 Result (J) := Pad; 558 end loop; 559 560 Result (Count - Source'Length + 1 .. Count) := Source; 561 return Result; 562 end; 563 end if; 564 end Tail; 565 566 procedure Tail 567 (Source : in out String; 568 Count : Natural; 569 Justify : Alignment := Left; 570 Pad : Character := Space) 571 is 572 begin 573 Move (Source => Tail (Source, Count, Pad), 574 Target => Source, 575 Drop => Error, 576 Justify => Justify, 577 Pad => Pad); 578 end Tail; 579 580 --------------- 581 -- Translate -- 582 --------------- 583 584 function Translate 585 (Source : String; 586 Mapping : Maps.Character_Mapping) return String 587 is 588 Result : String (1 .. Source'Length); 589 590 begin 591 for J in Source'Range loop 592 Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); 593 end loop; 594 595 return Result; 596 end Translate; 597 598 procedure Translate 599 (Source : in out String; 600 Mapping : Maps.Character_Mapping) 601 is 602 begin 603 for J in Source'Range loop 604 Source (J) := Value (Mapping, Source (J)); 605 end loop; 606 end Translate; 607 608 function Translate 609 (Source : String; 610 Mapping : Maps.Character_Mapping_Function) return String 611 is 612 Result : String (1 .. Source'Length); 613 pragma Unsuppress (Access_Check); 614 615 begin 616 for J in Source'Range loop 617 Result (J - (Source'First - 1)) := Mapping.all (Source (J)); 618 end loop; 619 620 return Result; 621 end Translate; 622 623 procedure Translate 624 (Source : in out String; 625 Mapping : Maps.Character_Mapping_Function) 626 is 627 pragma Unsuppress (Access_Check); 628 begin 629 for J in Source'Range loop 630 Source (J) := Mapping.all (Source (J)); 631 end loop; 632 end Translate; 633 634 ---------- 635 -- Trim -- 636 ---------- 637 638 function Trim 639 (Source : String; 640 Side : Trim_End) return String 641 is 642 begin 643 case Side is 644 when Strings.Left => 645 declare 646 Low : constant Natural := Index_Non_Blank (Source, Forward); 647 begin 648 -- All blanks case 649 650 if Low = 0 then 651 return ""; 652 end if; 653 654 declare 655 subtype Result_Type is String (1 .. Source'Last - Low + 1); 656 begin 657 return Result_Type (Source (Low .. Source'Last)); 658 end; 659 end; 660 661 when Strings.Right => 662 declare 663 High : constant Natural := Index_Non_Blank (Source, Backward); 664 begin 665 -- All blanks case 666 667 if High = 0 then 668 return ""; 669 end if; 670 671 declare 672 subtype Result_Type is String (1 .. High - Source'First + 1); 673 begin 674 return Result_Type (Source (Source'First .. High)); 675 end; 676 end; 677 678 when Strings.Both => 679 declare 680 Low : constant Natural := Index_Non_Blank (Source, Forward); 681 begin 682 -- All blanks case 683 684 if Low = 0 then 685 return ""; 686 end if; 687 688 declare 689 High : constant Natural := 690 Index_Non_Blank (Source, Backward); 691 subtype Result_Type is String (1 .. High - Low + 1); 692 begin 693 return Result_Type (Source (Low .. High)); 694 end; 695 end; 696 end case; 697 end Trim; 698 699 procedure Trim 700 (Source : in out String; 701 Side : Trim_End; 702 Justify : Alignment := Left; 703 Pad : Character := Space) 704 is 705 begin 706 Move (Trim (Source, Side), 707 Source, 708 Justify => Justify, 709 Pad => Pad); 710 end Trim; 711 712 function Trim 713 (Source : String; 714 Left : Maps.Character_Set; 715 Right : Maps.Character_Set) return String 716 is 717 High, Low : Integer; 718 719 begin 720 Low := Index (Source, Set => Left, Test => Outside, Going => Forward); 721 722 -- Case where source comprises only characters in Left 723 724 if Low = 0 then 725 return ""; 726 end if; 727 728 High := 729 Index (Source, Set => Right, Test => Outside, Going => Backward); 730 731 -- Case where source comprises only characters in Right 732 733 if High = 0 then 734 return ""; 735 end if; 736 737 declare 738 subtype Result_Type is String (1 .. High - Low + 1); 739 740 begin 741 return Result_Type (Source (Low .. High)); 742 end; 743 end Trim; 744 745 procedure Trim 746 (Source : in out String; 747 Left : Maps.Character_Set; 748 Right : Maps.Character_Set; 749 Justify : Alignment := Strings.Left; 750 Pad : Character := Space) 751 is 752 begin 753 Move (Source => Trim (Source, Left, Right), 754 Target => Source, 755 Justify => Justify, 756 Pad => Pad); 757 end Trim; 758 759end Ada.Strings.Fixed; 760