1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--               A D A . S T R I N G S . W I D E _ F I X E D                --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2019, 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
32with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps;
33with Ada.Strings.Wide_Wide_Search;
34
35package body Ada.Strings.Wide_Wide_Fixed is
36
37   ------------------------
38   -- Search Subprograms --
39   ------------------------
40
41   function Index
42     (Source  : Wide_Wide_String;
43      Pattern : Wide_Wide_String;
44      Going   : Direction := Forward;
45      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
46        Wide_Wide_Maps.Identity)
47      return Natural
48   renames Ada.Strings.Wide_Wide_Search.Index;
49
50   function Index
51     (Source  : Wide_Wide_String;
52      Pattern : Wide_Wide_String;
53      Going   : Direction := Forward;
54      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
55      return Natural
56   renames Ada.Strings.Wide_Wide_Search.Index;
57
58   function Index
59     (Source : Wide_Wide_String;
60      Set    : Wide_Wide_Maps.Wide_Wide_Character_Set;
61      Test   : Membership := Inside;
62      Going  : Direction  := Forward) return Natural
63   renames Ada.Strings.Wide_Wide_Search.Index;
64
65   function Index
66     (Source  : Wide_Wide_String;
67      Pattern : Wide_Wide_String;
68      From    : Positive;
69      Going   : Direction := Forward;
70      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
71        Wide_Wide_Maps.Identity)
72      return Natural
73   renames Ada.Strings.Wide_Wide_Search.Index;
74
75   function Index
76     (Source  : Wide_Wide_String;
77      Pattern : Wide_Wide_String;
78      From    : Positive;
79      Going   : Direction := Forward;
80      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
81      return Natural
82   renames Ada.Strings.Wide_Wide_Search.Index;
83
84   function Index
85     (Source  : Wide_Wide_String;
86      Set     : Wide_Wide_Maps.Wide_Wide_Character_Set;
87      From    : Positive;
88      Test    : Membership := Inside;
89      Going   : Direction := Forward) return Natural
90   renames Ada.Strings.Wide_Wide_Search.Index;
91
92   function Index_Non_Blank
93     (Source : Wide_Wide_String;
94      Going  : Direction := Forward) return Natural
95      renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank;
96
97   function Index_Non_Blank
98     (Source : Wide_Wide_String;
99      From   : Positive;
100      Going  : Direction := Forward) return Natural
101   renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank;
102
103   function Count
104     (Source  : Wide_Wide_String;
105      Pattern : Wide_Wide_String;
106      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
107        Wide_Wide_Maps.Identity)
108      return Natural
109   renames Ada.Strings.Wide_Wide_Search.Count;
110
111   function Count
112     (Source  : Wide_Wide_String;
113      Pattern : Wide_Wide_String;
114      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
115      return Natural
116   renames Ada.Strings.Wide_Wide_Search.Count;
117
118   function Count
119     (Source : Wide_Wide_String;
120      Set    : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
121   renames Ada.Strings.Wide_Wide_Search.Count;
122
123   procedure Find_Token
124     (Source : Wide_Wide_String;
125      Set    : Wide_Wide_Maps.Wide_Wide_Character_Set;
126      From   : Positive;
127      Test   : Membership;
128      First  : out Positive;
129      Last   : out Natural)
130   renames Ada.Strings.Wide_Wide_Search.Find_Token;
131
132   procedure Find_Token
133     (Source : Wide_Wide_String;
134      Set    : Wide_Wide_Maps.Wide_Wide_Character_Set;
135      Test   : Membership;
136      First  : out Positive;
137      Last   : out Natural)
138   renames Ada.Strings.Wide_Wide_Search.Find_Token;
139
140   ---------
141   -- "*" --
142   ---------
143
144   function "*"
145     (Left  : Natural;
146      Right : Wide_Wide_Character) return Wide_Wide_String
147   is
148      Result : Wide_Wide_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 : Wide_Wide_String) return Wide_Wide_String
161   is
162      Result : Wide_Wide_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  : Wide_Wide_String;
180      From    : Positive;
181      Through : Natural) return Wide_Wide_String
182   is
183   begin
184      if From not in Source'Range
185        or else Through > Source'Last
186      then
187         raise Index_Error;
188
189      elsif From > Through then
190         return Source;
191
192      else
193         declare
194            Len    : constant Integer := Source'Length - (Through - From + 1);
195            Result : constant Wide_Wide_String
196                       (Source'First .. Source'First + Len - 1) :=
197                          Source (Source'First .. From - 1) &
198                          Source (Through + 1 .. Source'Last);
199         begin
200            return Result;
201         end;
202      end if;
203   end Delete;
204
205   procedure Delete
206     (Source  : in out Wide_Wide_String;
207      From    : Positive;
208      Through : Natural;
209      Justify : Alignment := Left;
210      Pad     : Wide_Wide_Character := Wide_Wide_Space)
211   is
212   begin
213      Move (Source  => Delete (Source, From, Through),
214            Target  => Source,
215            Justify => Justify,
216            Pad     => Pad);
217   end Delete;
218
219   ----------
220   -- Head --
221   ----------
222
223   function Head
224     (Source : Wide_Wide_String;
225      Count  : Natural;
226      Pad    : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
227   is
228      Result : Wide_Wide_String (1 .. Count);
229
230   begin
231      if Count <= Source'Length then
232         Result := Source (Source'First .. Source'First + Count - 1);
233
234      else
235         Result (1 .. Source'Length) := Source;
236
237         for J in Source'Length + 1 .. Count loop
238            Result (J) := Pad;
239         end loop;
240      end if;
241
242      return Result;
243   end Head;
244
245   procedure Head
246     (Source  : in out Wide_Wide_String;
247      Count   : Natural;
248      Justify : Alignment := Left;
249      Pad     : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
250   is
251   begin
252      Move (Source  => Head (Source, Count, Pad),
253            Target  => Source,
254            Drop    => Error,
255            Justify => Justify,
256            Pad     => Pad);
257   end Head;
258
259   ------------
260   -- Insert --
261   ------------
262
263   function Insert
264     (Source   : Wide_Wide_String;
265      Before   : Positive;
266      New_Item : Wide_Wide_String) return Wide_Wide_String
267   is
268      Result : Wide_Wide_String (1 .. Source'Length + New_Item'Length);
269
270   begin
271      if Before < Source'First or else Before > Source'Last + 1 then
272         raise Index_Error;
273      end if;
274
275      Result := Source (Source'First .. Before - 1) & New_Item &
276                Source (Before .. Source'Last);
277      return Result;
278   end Insert;
279
280   procedure Insert
281     (Source   : in out Wide_Wide_String;
282      Before   : Positive;
283      New_Item : Wide_Wide_String;
284      Drop     : Truncation := Error)
285   is
286   begin
287      Move (Source => Insert (Source, Before, New_Item),
288            Target => Source,
289            Drop   => Drop);
290   end Insert;
291
292   ----------
293   -- Move --
294   ----------
295
296   procedure Move
297     (Source  : Wide_Wide_String;
298      Target  : out Wide_Wide_String;
299      Drop    : Truncation := Error;
300      Justify : Alignment  := Left;
301      Pad     : Wide_Wide_Character  := Wide_Wide_Space)
302   is
303      Sfirst  : constant Integer := Source'First;
304      Slast   : constant Integer := Source'Last;
305      Slength : constant Integer := Source'Length;
306
307      Tfirst  : constant Integer := Target'First;
308      Tlast   : constant Integer := Target'Last;
309      Tlength : constant Integer := Target'Length;
310
311      function Is_Padding (Item : Wide_Wide_String) return Boolean;
312      --  Determinbe if all characters in Item are pad characters
313
314      function Is_Padding (Item : Wide_Wide_String) return Boolean is
315      begin
316         for J in Item'Range loop
317            if Item (J) /= Pad then
318               return False;
319            end if;
320         end loop;
321
322         return True;
323      end Is_Padding;
324
325   --  Start of processing for Move
326
327   begin
328      if Slength = Tlength then
329         Target := Source;
330
331      elsif Slength > Tlength then
332         case Drop is
333            when Left =>
334               Target := Source (Slast - Tlength + 1 .. Slast);
335
336            when Right =>
337               Target := Source (Sfirst .. Sfirst + Tlength - 1);
338
339            when Error =>
340               case Justify is
341                  when Left =>
342                     if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
343                        Target :=
344                          Source (Sfirst .. Sfirst + Target'Length - 1);
345                     else
346                        raise Length_Error;
347                     end if;
348
349                  when Right =>
350                     if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
351                        Target := Source (Slast - Tlength + 1 .. Slast);
352                     else
353                        raise Length_Error;
354                     end if;
355
356                  when Center =>
357                     raise Length_Error;
358               end case;
359
360         end case;
361
362      --  Source'Length < Target'Length
363
364      else
365         case Justify is
366            when Left =>
367               Target (Tfirst .. Tfirst + Slength - 1) := Source;
368
369               for J in Tfirst + Slength .. Tlast loop
370                  Target (J) := Pad;
371               end loop;
372
373            when Right =>
374               for J in Tfirst .. Tlast - Slength loop
375                  Target (J) := Pad;
376               end loop;
377
378               Target (Tlast - Slength + 1 .. Tlast) := Source;
379
380            when Center =>
381               declare
382                  Front_Pad   : constant Integer := (Tlength - Slength) / 2;
383                  Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
384
385               begin
386                  for J in Tfirst .. Tfirst_Fpad - 1 loop
387                     Target (J) := Pad;
388                  end loop;
389
390                  Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
391
392                  for J in Tfirst_Fpad + Slength .. Tlast loop
393                     Target (J) := Pad;
394                  end loop;
395               end;
396         end case;
397      end if;
398   end Move;
399
400   ---------------
401   -- Overwrite --
402   ---------------
403
404   function Overwrite
405     (Source   : Wide_Wide_String;
406      Position : Positive;
407      New_Item : Wide_Wide_String) return Wide_Wide_String
408   is
409   begin
410      if Position not in Source'First .. Source'Last + 1 then
411         raise Index_Error;
412      else
413         declare
414            Result_Length : constant Natural :=
415              Natural'Max
416                (Source'Length,
417                 Position - Source'First + New_Item'Length);
418
419            Result : Wide_Wide_String (1 .. Result_Length);
420
421         begin
422            Result := Source (Source'First .. Position - 1) & New_Item &
423                        Source (Position + New_Item'Length .. Source'Last);
424            return Result;
425         end;
426      end if;
427   end Overwrite;
428
429   procedure Overwrite
430     (Source   : in out Wide_Wide_String;
431      Position : Positive;
432      New_Item : Wide_Wide_String;
433      Drop     : Truncation := Right)
434   is
435   begin
436      Move (Source => Overwrite (Source, Position, New_Item),
437            Target => Source,
438            Drop   => Drop);
439   end Overwrite;
440
441   -------------------
442   -- Replace_Slice --
443   -------------------
444
445   function Replace_Slice
446     (Source : Wide_Wide_String;
447      Low    : Positive;
448      High   : Natural;
449      By     : Wide_Wide_String) return Wide_Wide_String
450   is
451   begin
452      if Low > Source'Last + 1 or else High < Source'First - 1 then
453         raise Index_Error;
454      end if;
455
456      if High >= Low then
457         declare
458            Front_Len : constant Integer :=
459              Integer'Max (0, Low - Source'First);
460            --  Length of prefix of Source copied to result
461
462            Back_Len : constant Integer :=
463              Integer'Max (0, Source'Last - High);
464            --  Length of suffix of Source copied to result
465
466            Result_Length : constant Integer :=
467              Front_Len + By'Length + Back_Len;
468            --  Length of result
469
470            Result : Wide_Wide_String (1 .. Result_Length);
471
472         begin
473            Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
474            Result (Front_Len + 1 .. Front_Len + By'Length) := By;
475            Result (Front_Len + By'Length + 1 .. Result'Length) :=
476              Source (High + 1 .. Source'Last);
477            return Result;
478         end;
479
480      else
481         return Insert (Source, Before => Low, New_Item => By);
482      end if;
483   end Replace_Slice;
484
485   procedure Replace_Slice
486     (Source   : in out Wide_Wide_String;
487      Low      : Positive;
488      High     : Natural;
489      By       : Wide_Wide_String;
490      Drop     : Truncation := Error;
491      Justify  : Alignment  := Left;
492      Pad      : Wide_Wide_Character  := Wide_Wide_Space)
493   is
494   begin
495      Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
496   end Replace_Slice;
497
498   ----------
499   -- Tail --
500   ----------
501
502   function Tail
503     (Source : Wide_Wide_String;
504      Count  : Natural;
505      Pad    : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String
506   is
507      Result : Wide_Wide_String (1 .. Count);
508
509   begin
510      if Count < Source'Length then
511         Result := Source (Source'Last - Count + 1 .. Source'Last);
512
513      --  Pad on left
514
515      else
516         for J in 1 .. Count - Source'Length loop
517            Result (J) := Pad;
518         end loop;
519
520         Result (Count - Source'Length + 1 .. Count) := Source;
521      end if;
522
523      return Result;
524   end Tail;
525
526   procedure Tail
527     (Source  : in out Wide_Wide_String;
528      Count   : Natural;
529      Justify : Alignment := Left;
530      Pad     : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space)
531   is
532   begin
533      Move (Source  => Tail (Source, Count, Pad),
534            Target  => Source,
535            Drop    => Error,
536            Justify => Justify,
537            Pad     => Pad);
538   end Tail;
539
540   ---------------
541   -- Translate --
542   ---------------
543
544   function Translate
545     (Source  : Wide_Wide_String;
546      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
547      return Wide_Wide_String
548   is
549      Result : Wide_Wide_String (1 .. Source'Length);
550
551   begin
552      for J in Source'Range loop
553         Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
554      end loop;
555
556      return Result;
557   end Translate;
558
559   procedure Translate
560     (Source  : in out Wide_Wide_String;
561      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
562   is
563   begin
564      for J in Source'Range loop
565         Source (J) := Value (Mapping, Source (J));
566      end loop;
567   end Translate;
568
569   function Translate
570     (Source  : Wide_Wide_String;
571      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
572      return Wide_Wide_String
573   is
574      Result : Wide_Wide_String (1 .. Source'Length);
575
576   begin
577      for J in Source'Range loop
578         Result (J - (Source'First - 1)) := Mapping (Source (J));
579      end loop;
580
581      return Result;
582   end Translate;
583
584   procedure Translate
585     (Source  : in out Wide_Wide_String;
586      Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
587   is
588   begin
589      for J in Source'Range loop
590         Source (J) := Mapping (Source (J));
591      end loop;
592   end Translate;
593
594   ----------
595   -- Trim --
596   ----------
597
598   function Trim
599     (Source : Wide_Wide_String;
600      Side   : Trim_End) return Wide_Wide_String
601   is
602      Low  : Natural := Source'First;
603      High : Natural := Source'Last;
604
605   begin
606      if Side = Left or else Side = Both then
607         while Low <= High and then Source (Low) = Wide_Wide_Space loop
608            Low := Low + 1;
609         end loop;
610      end if;
611
612      if Side = Right or else Side = Both then
613         while High >= Low and then Source (High) = Wide_Wide_Space loop
614            High := High - 1;
615         end loop;
616      end if;
617
618      --  All blanks case
619
620      if Low > High then
621         return "";
622
623      --  At least one non-blank
624
625      else
626         declare
627            Result : constant Wide_Wide_String (1 .. High - Low + 1) :=
628              Source (Low .. High);
629
630         begin
631            return Result;
632         end;
633      end if;
634   end Trim;
635
636   procedure Trim
637     (Source  : in out Wide_Wide_String;
638      Side    : Trim_End;
639      Justify : Alignment      := Left;
640      Pad     : Wide_Wide_Character := Wide_Wide_Space)
641   is
642   begin
643      Move (Source  => Trim (Source, Side),
644            Target  => Source,
645            Justify => Justify,
646            Pad     => Pad);
647   end Trim;
648
649   function Trim
650      (Source : Wide_Wide_String;
651       Left   : Wide_Wide_Maps.Wide_Wide_Character_Set;
652       Right  : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String
653   is
654      Low  : Natural := Source'First;
655      High : Natural := Source'Last;
656
657   begin
658      while Low <= High and then Is_In (Source (Low), Left) loop
659         Low := Low + 1;
660      end loop;
661
662      while High >= Low and then Is_In (Source (High), Right) loop
663         High := High - 1;
664      end loop;
665
666      --  Case where source comprises only characters in the sets
667
668      if Low > High then
669         return "";
670      else
671         declare
672            subtype WS is Wide_Wide_String (1 .. High - Low + 1);
673
674         begin
675            return WS (Source (Low .. High));
676         end;
677      end if;
678   end Trim;
679
680   procedure Trim
681      (Source  : in out Wide_Wide_String;
682       Left    : Wide_Wide_Maps.Wide_Wide_Character_Set;
683       Right   : Wide_Wide_Maps.Wide_Wide_Character_Set;
684       Justify : Alignment      := Strings.Left;
685       Pad     : Wide_Wide_Character := Wide_Wide_Space)
686   is
687   begin
688      Move (Source  => Trim (Source, Left, Right),
689            Target  => Source,
690            Justify => Justify,
691            Pad     => Pad);
692   end Trim;
693
694end Ada.Strings.Wide_Wide_Fixed;
695