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-2012, 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 353 case Drop is 354 when Left => 355 Target := Source (Slast - Tlength + 1 .. Slast); 356 357 when Right => 358 Target := Source (Sfirst .. Sfirst + Tlength - 1); 359 360 when Error => 361 case Justify is 362 when Left => 363 if Is_Padding (Source (Sfirst + Tlength .. Slast)) then 364 Target := 365 Source (Sfirst .. Sfirst + Target'Length - 1); 366 else 367 raise Length_Error; 368 end if; 369 370 when Right => 371 if Is_Padding (Source (Sfirst .. Slast - Tlength)) then 372 Target := Source (Slast - Tlength + 1 .. Slast); 373 else 374 raise Length_Error; 375 end if; 376 377 when Center => 378 raise Length_Error; 379 end case; 380 381 end case; 382 383 -- Source'Length < Target'Length 384 385 else 386 case Justify is 387 when Left => 388 Target (Tfirst .. Tfirst + Slength - 1) := Source; 389 390 for I in Tfirst + Slength .. Tlast loop 391 Target (I) := Pad; 392 end loop; 393 394 when Right => 395 for I in Tfirst .. Tlast - Slength loop 396 Target (I) := Pad; 397 end loop; 398 399 Target (Tlast - Slength + 1 .. Tlast) := Source; 400 401 when Center => 402 declare 403 Front_Pad : constant Integer := (Tlength - Slength) / 2; 404 Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; 405 406 begin 407 for I in Tfirst .. Tfirst_Fpad - 1 loop 408 Target (I) := Pad; 409 end loop; 410 411 Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; 412 413 for I in Tfirst_Fpad + Slength .. Tlast loop 414 Target (I) := Pad; 415 end loop; 416 end; 417 end case; 418 end if; 419 end Move; 420 421 --------------- 422 -- Overwrite -- 423 --------------- 424 425 function Overwrite 426 (Source : String; 427 Position : Positive; 428 New_Item : String) return String 429 is 430 begin 431 if Position not in Source'First .. Source'Last + 1 then 432 raise Index_Error; 433 end if; 434 435 declare 436 Result_Length : constant Natural := 437 Integer'Max 438 (Source'Length, 439 Position - Source'First + New_Item'Length); 440 441 Result : String (1 .. Result_Length); 442 Front : constant Integer := Position - Source'First; 443 444 begin 445 Result (1 .. Front) := 446 Source (Source'First .. Position - 1); 447 Result (Front + 1 .. Front + New_Item'Length) := 448 New_Item; 449 Result (Front + New_Item'Length + 1 .. Result'Length) := 450 Source (Position + New_Item'Length .. Source'Last); 451 return Result; 452 end; 453 end Overwrite; 454 455 procedure Overwrite 456 (Source : in out String; 457 Position : Positive; 458 New_Item : String; 459 Drop : Truncation := Right) 460 is 461 begin 462 Move (Source => Overwrite (Source, Position, New_Item), 463 Target => Source, 464 Drop => Drop); 465 end Overwrite; 466 467 ------------------- 468 -- Replace_Slice -- 469 ------------------- 470 471 function Replace_Slice 472 (Source : String; 473 Low : Positive; 474 High : Natural; 475 By : String) return String 476 is 477 begin 478 if Low > Source'Last + 1 or else High < Source'First - 1 then 479 raise Index_Error; 480 end if; 481 482 if High >= Low then 483 declare 484 Front_Len : constant Integer := 485 Integer'Max (0, Low - Source'First); 486 -- Length of prefix of Source copied to result 487 488 Back_Len : constant Integer := 489 Integer'Max (0, Source'Last - High); 490 -- Length of suffix of Source copied to result 491 492 Result_Length : constant Integer := 493 Front_Len + By'Length + Back_Len; 494 -- Length of result 495 496 Result : String (1 .. Result_Length); 497 498 begin 499 Result (1 .. Front_Len) := Source (Source'First .. Low - 1); 500 Result (Front_Len + 1 .. Front_Len + By'Length) := By; 501 Result (Front_Len + By'Length + 1 .. Result'Length) := 502 Source (High + 1 .. Source'Last); 503 return Result; 504 end; 505 506 else 507 return Insert (Source, Before => Low, New_Item => By); 508 end if; 509 end Replace_Slice; 510 511 procedure Replace_Slice 512 (Source : in out String; 513 Low : Positive; 514 High : Natural; 515 By : String; 516 Drop : Truncation := Error; 517 Justify : Alignment := Left; 518 Pad : Character := Space) 519 is 520 begin 521 Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); 522 end Replace_Slice; 523 524 ---------- 525 -- Tail -- 526 ---------- 527 528 function Tail 529 (Source : String; 530 Count : Natural; 531 Pad : Character := Space) return String 532 is 533 subtype Result_Type is String (1 .. Count); 534 535 begin 536 if Count < Source'Length then 537 return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); 538 539 -- Pad on left 540 541 else 542 declare 543 Result : Result_Type; 544 545 begin 546 for J in 1 .. Count - Source'Length loop 547 Result (J) := Pad; 548 end loop; 549 550 Result (Count - Source'Length + 1 .. Count) := Source; 551 return Result; 552 end; 553 end if; 554 end Tail; 555 556 procedure Tail 557 (Source : in out String; 558 Count : Natural; 559 Justify : Alignment := Left; 560 Pad : Character := Space) 561 is 562 begin 563 Move (Source => Tail (Source, Count, Pad), 564 Target => Source, 565 Drop => Error, 566 Justify => Justify, 567 Pad => Pad); 568 end Tail; 569 570 --------------- 571 -- Translate -- 572 --------------- 573 574 function Translate 575 (Source : String; 576 Mapping : Maps.Character_Mapping) return String 577 is 578 Result : String (1 .. Source'Length); 579 580 begin 581 for J in Source'Range loop 582 Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); 583 end loop; 584 585 return Result; 586 end Translate; 587 588 procedure Translate 589 (Source : in out String; 590 Mapping : Maps.Character_Mapping) 591 is 592 begin 593 for J in Source'Range loop 594 Source (J) := Value (Mapping, Source (J)); 595 end loop; 596 end Translate; 597 598 function Translate 599 (Source : String; 600 Mapping : Maps.Character_Mapping_Function) return String 601 is 602 Result : String (1 .. Source'Length); 603 pragma Unsuppress (Access_Check); 604 605 begin 606 for J in Source'Range loop 607 Result (J - (Source'First - 1)) := Mapping.all (Source (J)); 608 end loop; 609 610 return Result; 611 end Translate; 612 613 procedure Translate 614 (Source : in out String; 615 Mapping : Maps.Character_Mapping_Function) 616 is 617 pragma Unsuppress (Access_Check); 618 begin 619 for J in Source'Range loop 620 Source (J) := Mapping.all (Source (J)); 621 end loop; 622 end Translate; 623 624 ---------- 625 -- Trim -- 626 ---------- 627 628 function Trim 629 (Source : String; 630 Side : Trim_End) return String 631 is 632 Low, High : Integer; 633 634 begin 635 Low := Index_Non_Blank (Source, Forward); 636 637 -- All blanks case 638 639 if Low = 0 then 640 return ""; 641 642 -- At least one non-blank 643 644 else 645 High := Index_Non_Blank (Source, Backward); 646 647 case Side is 648 when Strings.Left => 649 declare 650 subtype Result_Type is String (1 .. Source'Last - Low + 1); 651 652 begin 653 return Result_Type (Source (Low .. Source'Last)); 654 end; 655 656 when Strings.Right => 657 declare 658 subtype Result_Type is String (1 .. High - Source'First + 1); 659 660 begin 661 return Result_Type (Source (Source'First .. High)); 662 end; 663 664 when Strings.Both => 665 declare 666 subtype Result_Type is String (1 .. High - Low + 1); 667 668 begin 669 return Result_Type (Source (Low .. High)); 670 end; 671 end case; 672 end if; 673 end Trim; 674 675 procedure Trim 676 (Source : in out String; 677 Side : Trim_End; 678 Justify : Alignment := Left; 679 Pad : Character := Space) 680 is 681 begin 682 Move (Trim (Source, Side), 683 Source, 684 Justify => Justify, 685 Pad => Pad); 686 end Trim; 687 688 function Trim 689 (Source : String; 690 Left : Maps.Character_Set; 691 Right : Maps.Character_Set) return String 692 is 693 High, Low : Integer; 694 695 begin 696 Low := Index (Source, Set => Left, Test => Outside, Going => Forward); 697 698 -- Case where source comprises only characters in Left 699 700 if Low = 0 then 701 return ""; 702 end if; 703 704 High := 705 Index (Source, Set => Right, Test => Outside, Going => Backward); 706 707 -- Case where source comprises only characters in Right 708 709 if High = 0 then 710 return ""; 711 end if; 712 713 declare 714 subtype Result_Type is String (1 .. High - Low + 1); 715 716 begin 717 return Result_Type (Source (Low .. High)); 718 end; 719 end Trim; 720 721 procedure Trim 722 (Source : in out String; 723 Left : Maps.Character_Set; 724 Right : Maps.Character_Set; 725 Justify : Alignment := Strings.Left; 726 Pad : Character := Space) 727 is 728 begin 729 Move (Source => Trim (Source, Left, Right), 730 Target => Source, 731 Justify => Justify, 732 Pad => Pad); 733 end Trim; 734 735end Ada.Strings.Fixed; 736