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-2018, 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 raise Index_Error; 196 197 else 198 declare 199 Front : constant Integer := From - Source'First; 200 Result : String (1 .. Source'Length - (Through - From + 1)); 201 202 begin 203 Result (1 .. Front) := 204 Source (Source'First .. From - 1); 205 Result (Front + 1 .. Result'Last) := 206 Source (Through + 1 .. Source'Last); 207 208 return Result; 209 end; 210 end if; 211 end Delete; 212 213 procedure Delete 214 (Source : in out String; 215 From : Positive; 216 Through : Natural; 217 Justify : Alignment := Left; 218 Pad : Character := Space) 219 is 220 begin 221 Move (Source => Delete (Source, From, Through), 222 Target => Source, 223 Justify => Justify, 224 Pad => Pad); 225 end Delete; 226 227 ---------- 228 -- Head -- 229 ---------- 230 231 function Head 232 (Source : String; 233 Count : Natural; 234 Pad : Character := Space) return String 235 is 236 subtype Result_Type is String (1 .. Count); 237 238 begin 239 if Count < Source'Length then 240 return 241 Result_Type (Source (Source'First .. Source'First + Count - 1)); 242 243 else 244 declare 245 Result : Result_Type; 246 247 begin 248 Result (1 .. Source'Length) := Source; 249 250 for J in Source'Length + 1 .. Count loop 251 Result (J) := Pad; 252 end loop; 253 254 return Result; 255 end; 256 end if; 257 end Head; 258 259 procedure Head 260 (Source : in out String; 261 Count : Natural; 262 Justify : Alignment := Left; 263 Pad : Character := Space) 264 is 265 begin 266 Move (Source => Head (Source, Count, Pad), 267 Target => Source, 268 Drop => Error, 269 Justify => Justify, 270 Pad => Pad); 271 end Head; 272 273 ------------ 274 -- Insert -- 275 ------------ 276 277 function Insert 278 (Source : String; 279 Before : Positive; 280 New_Item : String) return String 281 is 282 Result : String (1 .. Source'Length + New_Item'Length); 283 Front : constant Integer := Before - Source'First; 284 285 begin 286 if Before not in Source'First .. Source'Last + 1 then 287 raise Index_Error; 288 end if; 289 290 Result (1 .. Front) := 291 Source (Source'First .. Before - 1); 292 Result (Front + 1 .. Front + New_Item'Length) := 293 New_Item; 294 Result (Front + New_Item'Length + 1 .. Result'Last) := 295 Source (Before .. Source'Last); 296 297 return Result; 298 end Insert; 299 300 procedure Insert 301 (Source : in out String; 302 Before : Positive; 303 New_Item : String; 304 Drop : Truncation := Error) 305 is 306 begin 307 Move (Source => Insert (Source, Before, New_Item), 308 Target => Source, 309 Drop => Drop); 310 end Insert; 311 312 ---------- 313 -- Move -- 314 ---------- 315 316 procedure Move 317 (Source : String; 318 Target : out String; 319 Drop : Truncation := Error; 320 Justify : Alignment := Left; 321 Pad : Character := Space) 322 is 323 Sfirst : constant Integer := Source'First; 324 Slast : constant Integer := Source'Last; 325 Slength : constant Integer := Source'Length; 326 327 Tfirst : constant Integer := Target'First; 328 Tlast : constant Integer := Target'Last; 329 Tlength : constant Integer := Target'Length; 330 331 function Is_Padding (Item : String) return Boolean; 332 -- Check if Item is all Pad characters, return True if so, False if not 333 334 function Is_Padding (Item : String) return Boolean is 335 begin 336 for J in Item'Range loop 337 if Item (J) /= Pad then 338 return False; 339 end if; 340 end loop; 341 342 return True; 343 end Is_Padding; 344 345 -- Start of processing for Move 346 347 begin 348 if Slength = Tlength then 349 Target := Source; 350 351 elsif Slength > Tlength then 352 case Drop is 353 when Left => 354 Target := Source (Slast - Tlength + 1 .. Slast); 355 356 when Right => 357 Target := Source (Sfirst .. Sfirst + Tlength - 1); 358 359 when Error => 360 case Justify is 361 when Left => 362 if Is_Padding (Source (Sfirst + Tlength .. Slast)) then 363 Target := 364 Source (Sfirst .. Sfirst + Target'Length - 1); 365 else 366 raise Length_Error; 367 end if; 368 369 when Right => 370 if Is_Padding (Source (Sfirst .. Slast - Tlength)) then 371 Target := Source (Slast - Tlength + 1 .. Slast); 372 else 373 raise Length_Error; 374 end if; 375 376 when Center => 377 raise Length_Error; 378 end case; 379 end case; 380 381 -- Source'Length < Target'Length 382 383 else 384 case Justify is 385 when Left => 386 Target (Tfirst .. Tfirst + Slength - 1) := Source; 387 388 for I in Tfirst + Slength .. Tlast loop 389 Target (I) := Pad; 390 end loop; 391 392 when Right => 393 for I in Tfirst .. Tlast - Slength loop 394 Target (I) := Pad; 395 end loop; 396 397 Target (Tlast - Slength + 1 .. Tlast) := Source; 398 399 when Center => 400 declare 401 Front_Pad : constant Integer := (Tlength - Slength) / 2; 402 Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; 403 404 begin 405 for I in Tfirst .. Tfirst_Fpad - 1 loop 406 Target (I) := Pad; 407 end loop; 408 409 Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; 410 411 for I in Tfirst_Fpad + Slength .. Tlast loop 412 Target (I) := Pad; 413 end loop; 414 end; 415 end case; 416 end if; 417 end Move; 418 419 --------------- 420 -- Overwrite -- 421 --------------- 422 423 function Overwrite 424 (Source : String; 425 Position : Positive; 426 New_Item : String) return String 427 is 428 begin 429 if Position not in Source'First .. Source'Last + 1 then 430 raise Index_Error; 431 end if; 432 433 declare 434 Result_Length : constant Natural := 435 Integer'Max 436 (Source'Length, 437 Position - Source'First + New_Item'Length); 438 439 Result : String (1 .. Result_Length); 440 Front : constant Integer := Position - Source'First; 441 442 begin 443 Result (1 .. Front) := 444 Source (Source'First .. Position - 1); 445 Result (Front + 1 .. Front + New_Item'Length) := 446 New_Item; 447 Result (Front + New_Item'Length + 1 .. Result'Length) := 448 Source (Position + New_Item'Length .. Source'Last); 449 return Result; 450 end; 451 end Overwrite; 452 453 procedure Overwrite 454 (Source : in out String; 455 Position : Positive; 456 New_Item : String; 457 Drop : Truncation := Right) 458 is 459 begin 460 Move (Source => Overwrite (Source, Position, New_Item), 461 Target => Source, 462 Drop => Drop); 463 end Overwrite; 464 465 ------------------- 466 -- Replace_Slice -- 467 ------------------- 468 469 function Replace_Slice 470 (Source : String; 471 Low : Positive; 472 High : Natural; 473 By : String) return String 474 is 475 begin 476 if Low > Source'Last + 1 or else High < Source'First - 1 then 477 raise Index_Error; 478 end if; 479 480 if High >= Low then 481 declare 482 Front_Len : constant Integer := 483 Integer'Max (0, Low - Source'First); 484 -- Length of prefix of Source copied to result 485 486 Back_Len : constant Integer := 487 Integer'Max (0, Source'Last - High); 488 -- Length of suffix of Source copied to result 489 490 Result_Length : constant Integer := 491 Front_Len + By'Length + Back_Len; 492 -- Length of result 493 494 Result : String (1 .. Result_Length); 495 496 begin 497 Result (1 .. Front_Len) := Source (Source'First .. Low - 1); 498 Result (Front_Len + 1 .. Front_Len + By'Length) := By; 499 Result (Front_Len + By'Length + 1 .. Result'Length) := 500 Source (High + 1 .. Source'Last); 501 return Result; 502 end; 503 504 else 505 return Insert (Source, Before => Low, New_Item => By); 506 end if; 507 end Replace_Slice; 508 509 procedure Replace_Slice 510 (Source : in out String; 511 Low : Positive; 512 High : Natural; 513 By : String; 514 Drop : Truncation := Error; 515 Justify : Alignment := Left; 516 Pad : Character := Space) 517 is 518 begin 519 Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); 520 end Replace_Slice; 521 522 ---------- 523 -- Tail -- 524 ---------- 525 526 function Tail 527 (Source : String; 528 Count : Natural; 529 Pad : Character := Space) return String 530 is 531 subtype Result_Type is String (1 .. Count); 532 533 begin 534 if Count < Source'Length then 535 return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); 536 537 -- Pad on left 538 539 else 540 declare 541 Result : Result_Type; 542 543 begin 544 for J in 1 .. Count - Source'Length loop 545 Result (J) := Pad; 546 end loop; 547 548 Result (Count - Source'Length + 1 .. Count) := Source; 549 return Result; 550 end; 551 end if; 552 end Tail; 553 554 procedure Tail 555 (Source : in out String; 556 Count : Natural; 557 Justify : Alignment := Left; 558 Pad : Character := Space) 559 is 560 begin 561 Move (Source => Tail (Source, Count, Pad), 562 Target => Source, 563 Drop => Error, 564 Justify => Justify, 565 Pad => Pad); 566 end Tail; 567 568 --------------- 569 -- Translate -- 570 --------------- 571 572 function Translate 573 (Source : String; 574 Mapping : Maps.Character_Mapping) return String 575 is 576 Result : String (1 .. Source'Length); 577 578 begin 579 for J in Source'Range loop 580 Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); 581 end loop; 582 583 return Result; 584 end Translate; 585 586 procedure Translate 587 (Source : in out String; 588 Mapping : Maps.Character_Mapping) 589 is 590 begin 591 for J in Source'Range loop 592 Source (J) := Value (Mapping, Source (J)); 593 end loop; 594 end Translate; 595 596 function Translate 597 (Source : String; 598 Mapping : Maps.Character_Mapping_Function) return String 599 is 600 Result : String (1 .. Source'Length); 601 pragma Unsuppress (Access_Check); 602 603 begin 604 for J in Source'Range loop 605 Result (J - (Source'First - 1)) := Mapping.all (Source (J)); 606 end loop; 607 608 return Result; 609 end Translate; 610 611 procedure Translate 612 (Source : in out String; 613 Mapping : Maps.Character_Mapping_Function) 614 is 615 pragma Unsuppress (Access_Check); 616 begin 617 for J in Source'Range loop 618 Source (J) := Mapping.all (Source (J)); 619 end loop; 620 end Translate; 621 622 ---------- 623 -- Trim -- 624 ---------- 625 626 function Trim 627 (Source : String; 628 Side : Trim_End) return String 629 is 630 begin 631 case Side is 632 when Strings.Left => 633 declare 634 Low : constant Natural := Index_Non_Blank (Source, Forward); 635 begin 636 -- All blanks case 637 638 if Low = 0 then 639 return ""; 640 end if; 641 642 declare 643 subtype Result_Type is String (1 .. Source'Last - Low + 1); 644 begin 645 return Result_Type (Source (Low .. Source'Last)); 646 end; 647 end; 648 649 when Strings.Right => 650 declare 651 High : constant Natural := Index_Non_Blank (Source, Backward); 652 begin 653 -- All blanks case 654 655 if High = 0 then 656 return ""; 657 end if; 658 659 declare 660 subtype Result_Type is String (1 .. High - Source'First + 1); 661 begin 662 return Result_Type (Source (Source'First .. High)); 663 end; 664 end; 665 666 when Strings.Both => 667 declare 668 Low : constant Natural := Index_Non_Blank (Source, Forward); 669 begin 670 -- All blanks case 671 672 if Low = 0 then 673 return ""; 674 end if; 675 676 declare 677 High : constant Natural := 678 Index_Non_Blank (Source, Backward); 679 subtype Result_Type is String (1 .. High - Low + 1); 680 begin 681 return Result_Type (Source (Low .. High)); 682 end; 683 end; 684 end case; 685 end Trim; 686 687 procedure Trim 688 (Source : in out String; 689 Side : Trim_End; 690 Justify : Alignment := Left; 691 Pad : Character := Space) 692 is 693 begin 694 Move (Trim (Source, Side), 695 Source, 696 Justify => Justify, 697 Pad => Pad); 698 end Trim; 699 700 function Trim 701 (Source : String; 702 Left : Maps.Character_Set; 703 Right : Maps.Character_Set) return String 704 is 705 High, Low : Integer; 706 707 begin 708 Low := Index (Source, Set => Left, Test => Outside, Going => Forward); 709 710 -- Case where source comprises only characters in Left 711 712 if Low = 0 then 713 return ""; 714 end if; 715 716 High := 717 Index (Source, Set => Right, Test => Outside, Going => Backward); 718 719 -- Case where source comprises only characters in Right 720 721 if High = 0 then 722 return ""; 723 end if; 724 725 declare 726 subtype Result_Type is String (1 .. High - Low + 1); 727 728 begin 729 return Result_Type (Source (Low .. High)); 730 end; 731 end Trim; 732 733 procedure Trim 734 (Source : in out String; 735 Left : Maps.Character_Set; 736 Right : Maps.Character_Set; 737 Justify : Alignment := Strings.Left; 738 Pad : Character := Space) 739 is 740 begin 741 Move (Source => Trim (Source, Left, Right), 742 Target => Source, 743 Justify => Justify, 744 Pad => Pad); 745 end Trim; 746 747end Ada.Strings.Fixed; 748