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