File : a-strfix.adb
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
5 -- A D A . S T R I N G S . F I X E D --
-- --
-- B o d y --
-- --
-- $Revision: 1.19 $
10 -- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
30 -- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
35
-- Note: This code is derived from the ADAR.CSH public domain Ada 83
-- versions of the Appendix C string handling packages. One change is
-- to avoid the use of Is_In, so that we are not dependent on inlining.
-- Note that the search function implementations are to be found in the
40 -- auxiliary package Ada.Strings.Search. Also the Move procedure is
-- directly incorporated (ADAR used a subunit for this procedure). A
-- number of errors having to do with bounds of function return results
-- were also fixed, and use of & removed for efficiency reasons.
45 with Ada.Strings.Maps; use Ada.Strings.Maps;
with Ada.Strings.Search;
package body Ada.Strings.Fixed is
50 ------------------------
-- Search Subprograms --
------------------------
function Index
55 (Source : in String;
Pattern : in String;
Going : in Direction := Forward;
Mapping : in Maps.Character_Mapping := Maps.Identity)
return Natural
60 renames Ada.Strings.Search.Index;
function Index
(Source : in String;
Pattern : in String;
65 Going : in Direction := Forward;
Mapping : in Maps.Character_Mapping_Function)
return Natural
renames Ada.Strings.Search.Index;
70 function Index
(Source : in String;
Set : in Maps.Character_Set;
Test : in Membership := Inside;
Going : in Direction := Forward)
75 return Natural
renames Ada.Strings.Search.Index;
function Index_Non_Blank
(Source : in String;
80 Going : in Direction := Forward)
return Natural
renames Ada.Strings.Search.Index_Non_Blank;
function Count
85 (Source : in String;
Pattern : in String;
Mapping : in Maps.Character_Mapping := Maps.Identity)
return Natural
renames Ada.Strings.Search.Count;
90
function Count
(Source : in String;
Pattern : in String;
Mapping : in Maps.Character_Mapping_Function)
95 return Natural
renames Ada.Strings.Search.Count;
function Count
(Source : in String;
100 Set : in Maps.Character_Set)
return Natural
renames Ada.Strings.Search.Count;
procedure Find_Token
105 (Source : in String;
Set : in Maps.Character_Set;
Test : in Membership;
First : out Positive;
Last : out Natural)
110 renames Ada.Strings.Search.Find_Token;
---------
-- "*" --
---------
115
function "*"
(Left : in Natural;
Right : in Character)
return String
120 is
Result : String (1 .. Left);
begin
for J in Result'Range loop
125 Result (J) := Right;
end loop;
return Result;
end "*";
130
function "*"
(Left : in Natural;
Right : in String)
return String
135 is
Result : String (1 .. Left * Right'Length);
Ptr : Integer := 1;
begin
140 for J in 1 .. Left loop
Result (Ptr .. Ptr + Right'Length - 1) := Right;
Ptr := Ptr + Right'Length;
end loop;
145 return Result;
end "*";
------------
-- Delete --
150 ------------
function Delete
(Source : in String;
From : in Positive;
155 Through : in Natural)
return String
is
begin
if From > Through then
160 declare
subtype Result_Type is String (1 .. Source'Length);
begin
return Result_Type (Source);
165 end;
elsif From not in Source'Range
or else Through > Source'Last
then
170 raise Index_Error;
else
declare
Front : constant Integer := From - Source'First;
175 Result : String (1 .. Source'Length - (Through - From + 1));
begin
Result (1 .. Front) :=
Source (Source'First .. From - 1);
180 Result (Front + 1 .. Result'Last) :=
Source (Through + 1 .. Source'Last);
return Result;
end;
185 end if;
end Delete;
procedure Delete
(Source : in out String;
190 From : in Positive;
Through : in Natural;
Justify : in Alignment := Left;
Pad : in Character := Space)
is
195 begin
Move (Source => Delete (Source, From, Through),
Target => Source,
Justify => Justify,
Pad => Pad);
200 end Delete;
----------
-- Head --
----------
205
function Head
(Source : in String;
Count : in Natural;
Pad : in Character := Space)
210 return String
is
subtype Result_Type is String (1 .. Count);
begin
215 if Count < Source'Length then
return
Result_Type (Source (Source'First .. Source'First + Count - 1));
else
220 declare
Result : Result_Type;
begin
Result (1 .. Source'Length) := Source;
225
for J in Source'Length + 1 .. Count loop
Result (J) := Pad;
end loop;
230 return Result;
end;
end if;
end Head;
235 procedure Head
(Source : in out String;
Count : in Natural;
Justify : in Alignment := Left;
Pad : in Character := Space)
240 is
begin
Move (Source => Head (Source, Count, Pad),
Target => Source,
Drop => Error,
245 Justify => Justify,
Pad => Pad);
end Head;
------------
250 -- Insert --
------------
function Insert
(Source : in String;
255 Before : in Positive;
New_Item : in String)
return String
is
Result : String (1 .. Source'Length + New_Item'Length);
260 Front : constant Integer := Before - Source'First;
begin
if Before not in Source'First .. Source'Last + 1 then
raise Index_Error;
265 end if;
Result (1 .. Front) :=
Source (Source'First .. Before - 1);
Result (Front + 1 .. Front + New_Item'Length) :=
270 New_Item;
Result (Front + New_Item'Length + 1 .. Result'Last) :=
Source (Before .. Source'Last);
return Result;
275 end Insert;
procedure Insert
(Source : in out String;
Before : in Positive;
280 New_Item : in String;
Drop : in Truncation := Error)
is
begin
Move (Source => Insert (Source, Before, New_Item),
285 Target => Source,
Drop => Drop);
end Insert;
----------
290 -- Move --
----------
procedure Move
(Source : in String;
295 Target : out String;
Drop : in Truncation := Error;
Justify : in Alignment := Left;
Pad : in Character := Space)
is
300 Sfirst : constant Integer := Source'First;
Slast : constant Integer := Source'Last;
Slength : constant Integer := Source'Length;
Tfirst : constant Integer := Target'First;
305 Tlast : constant Integer := Target'Last;
Tlength : constant Integer := Target'Length;
function Is_Padding (Item : String) return Boolean;
-- Check if Item is all Pad characters, return True if so, False if not
310
function Is_Padding (Item : String) return Boolean is
begin
for J in Item'Range loop
if Item (J) /= Pad then
315 return False;
end if;
end loop;
return True;
320 end Is_Padding;
-- Start of processing for Move
begin
325 if Slength = Tlength then
Target := Source;
elsif Slength > Tlength then
330 case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
when Right =>
335 Target := Source (Sfirst .. Sfirst + Tlength - 1);
when Error =>
case Justify is
when Left =>
340 if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
Target :=
Source (Sfirst .. Sfirst + Target'Length - 1);
else
raise Length_Error;
345 end if;
when Right =>
if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
Target := Source (Slast - Tlength + 1 .. Slast);
350 else
raise Length_Error;
end if;
when Center =>
355 raise Length_Error;
end case;
end case;
360 -- Source'Length < Target'Length
else
case Justify is
when Left =>
365 Target (Tfirst .. Tfirst + Slength - 1) := Source;
for I in Tfirst + Slength .. Tlast loop
Target (I) := Pad;
end loop;
370
when Right =>
for I in Tfirst .. Tlast - Slength loop
Target (I) := Pad;
end loop;
375
Target (Tlast - Slength + 1 .. Tlast) := Source;
when Center =>
declare
380 Front_Pad : constant Integer := (Tlength - Slength) / 2;
Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
begin
for I in Tfirst .. Tfirst_Fpad - 1 loop
385 Target (I) := Pad;
end loop;
Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
390 for I in Tfirst_Fpad + Slength .. Tlast loop
Target (I) := Pad;
end loop;
end;
end case;
395 end if;
end Move;
---------------
-- Overwrite --
400 ---------------
function Overwrite
(Source : in String;
Position : in Positive;
405 New_Item : in String)
return String
is
begin
if Position not in Source'First .. Source'Last + 1 then
410 raise Index_Error;
end if;
declare
Result_Length : Natural :=
415 Integer'Max
(Source'Length, Position - Source'First + New_Item'Length);
Result : String (1 .. Result_Length);
Front : constant Integer := Position - Source'First;
420
begin
Result (1 .. Front) :=
Source (Source'First .. Position - 1);
Result (Front + 1 .. Front + New_Item'Length) :=
425 New_Item;
Result (Front + New_Item'Length + 1 .. Result'Length) :=
Source (Position + New_Item'Length .. Source'Last);
return Result;
end;
430 end Overwrite;
procedure Overwrite
(Source : in out String;
Position : in Positive;
435 New_Item : in String;
Drop : in Truncation := Right)
is
begin
Move (Source => Overwrite (Source, Position, New_Item),
440 Target => Source,
Drop => Drop);
end Overwrite;
-------------------
445 -- Replace_Slice --
-------------------
function Replace_Slice
(Source : in String;
450 Low : in Positive;
High : in Natural;
By : in String)
return String
is
455 begin
if Low > Source'Last + 1 or High < Source'First - 1 then
raise Index_Error;
end if;
460 if High >= Low then
declare
Front_Len : constant Integer :=
Integer'Max (0, Low - Source'First);
-- Length of prefix of Source copied to result
465
Back_Len : constant Integer :=
Integer'Max (0, Source'Last - High);
-- Length of suffix of Source copied to result
470 Result_Length : constant Integer :=
Front_Len + By'Length + Back_Len;
-- Length of result
Result : String (1 .. Result_Length);
475
begin
Result (1 .. Front_Len) :=
Source (Source'First .. Low - 1);
Result (Front_Len + 1 .. Front_Len + By'Length) :=
480 By;
Result (Front_Len + By'Length + 1 .. Result'Length) :=
Source (High + 1 .. Source'Last);
return Result;
485 end;
else
return Insert (Source, Before => Low, New_Item => By);
end if;
490 end Replace_Slice;
procedure Replace_Slice
(Source : in out String;
Low : in Positive;
495 High : in Natural;
By : in String;
Drop : in Truncation := Error;
Justify : in Alignment := Left;
Pad : in Character := Space)
500 is
begin
Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
end Replace_Slice;
505 ----------
-- Tail --
----------
function Tail
510 (Source : in String;
Count : in Natural;
Pad : in Character := Space)
return String
is
515 subtype Result_Type is String (1 .. Count);
begin
if Count < Source'Length then
return Result_Type (Source (Source'Last - Count + 1 .. Source'Last));
520
-- Pad on left
else
declare
525 Result : Result_Type;
begin
for J in 1 .. Count - Source'Length loop
Result (J) := Pad;
530 end loop;
Result (Count - Source'Length + 1 .. Count) := Source;
return Result;
end;
535 end if;
end Tail;
procedure Tail
(Source : in out String;
540 Count : in Natural;
Justify : in Alignment := Left;
Pad : in Character := Space)
is
begin
545 Move (Source => Tail (Source, Count, Pad),
Target => Source,
Drop => Error,
Justify => Justify,
Pad => Pad);
550 end Tail;
---------------
-- Translate --
---------------
555
function Translate
(Source : in String;
Mapping : in Maps.Character_Mapping)
return String
560 is
Result : String (1 .. Source'Length);
begin
for J in Source'Range loop
565 Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
end loop;
return Result;
end Translate;
570
procedure Translate
(Source : in out String;
Mapping : in Maps.Character_Mapping)
is
575 begin
for J in Source'Range loop
Source (J) := Value (Mapping, Source (J));
end loop;
end Translate;
580
function Translate
(Source : in String;
Mapping : in Maps.Character_Mapping_Function)
return String
585 is
Result : String (1 .. Source'Length);
pragma Unsuppress (Access_Check);
begin
590 for J in Source'Range loop
Result (J - (Source'First - 1)) := Mapping.all (Source (J));
end loop;
return Result;
595 end Translate;
procedure Translate
(Source : in out String;
Mapping : in Maps.Character_Mapping_Function)
600 is
pragma Unsuppress (Access_Check);
begin
for J in Source'Range loop
Source (J) := Mapping.all (Source (J));
605 end loop;
end Translate;
----------
-- Trim --
610 ----------
function Trim
(Source : in String;
Side : in Trim_End)
615 return String
is
Low, High : Integer;
begin
620 Low := Index_Non_Blank (Source, Forward);
-- All blanks case
if Low = 0 then
625 return "";
-- At least one non-blank
else
630 High := Index_Non_Blank (Source, Backward);
case Side is
when Strings.Left =>
declare
635 subtype Result_Type is String (1 .. Source'Last - Low + 1);
begin
return Result_Type (Source (Low .. Source'Last));
end;
640
when Strings.Right =>
declare
subtype Result_Type is String (1 .. High - Source'First + 1);
645 begin
return Result_Type (Source (Source'First .. High));
end;
when Strings.Both =>
650 declare
subtype Result_Type is String (1 .. High - Low + 1);
begin
return Result_Type (Source (Low .. High));
655 end;
end case;
end if;
end Trim;
660 procedure Trim
(Source : in out String;
Side : in Trim_End;
Justify : in Alignment := Left;
Pad : in Character := Space)
665 is
begin
Move (Trim (Source, Side),
Source,
Justify => Justify,
670 Pad => Pad);
end Trim;
function Trim
(Source : in String;
675 Left : in Maps.Character_Set;
Right : in Maps.Character_Set)
return String
is
High, Low : Integer;
680
begin
Low := Index (Source, Set => Left, Test => Outside, Going => Forward);
-- Case where source comprises only characters in Left
685
if Low = 0 then
return "";
end if;
690 High :=
Index (Source, Set => Right, Test => Outside, Going => Backward);
-- Case where source comprises only characters in Right
695 if High = 0 then
return "";
end if;
declare
700 subtype Result_Type is String (1 .. High - Low + 1);
begin
return Result_Type (Source (Low .. High));
end;
705 end Trim;
procedure Trim
(Source : in out String;
Left : in Maps.Character_Set;
710 Right : in Maps.Character_Set;
Justify : in Alignment := Strings.Left;
Pad : in Character := Space)
is
begin
715 Move (Source => Trim (Source, Left, Right),
Target => Source,
Justify => Justify,
Pad => Pad);
end Trim;
720
end Ada.Strings.Fixed;