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