gcc/ada/g-rewdat.adb

   1 -----------------------------------------------------------------------------
   2 --                         GNAT COMPILER COMPONENTS                         --
   3 --                                                                          --
   4 --                     G N A T . R E W R I T E _ D A T A                    --
   5 --                                                                          --
   6 --                                 B o d y                                  --
   7 --                                                                          --
   8 --            Copyright (C) 2014, Free Software Foundation, Inc.            --
   9 --                                                                          --
  10 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  11 -- terms of the  GNU General Public License as published  by the Free Soft- --
  12 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  13 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  14 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  15 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  16 --                                                                          --
  17 -- As a special exception under Section 7 of GPL version 3, you are granted --
  18 -- additional permissions described in the GCC Runtime Library Exception,   --
  19 -- version 3.1, as published by the Free Software Foundation.               --
  20 --                                                                          --
  21 -- You should have received a copy of the GNU General Public License and    --
  22 -- a copy of the GCC Runtime Library Exception along with this program;     --
  23 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  24 -- <http://www.gnu.org/licenses/>.                                          --
  25 --                                                                          --
  26 -- GNAT was originally developed  by the GNAT team at  New York University. --
  27 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  28 --                                                                          --
  29 ------------------------------------------------------------------------------
  30
  31 with Ada.Unchecked_Conversion;
  32
  33 package body GNAT.Rewrite_Data is
  34
  35    use Ada;
  36
  37    subtype SEO is Stream_Element_Offset;
  38
  39    procedure Do_Output
  40      (B      : in out Buffer;
  41       Data   : Stream_Element_Array;
  42       Output : not null access procedure (Data : Stream_Element_Array));
  43    --  Do the actual output. This ensures that we properly send the data
  44    --  through linked rewrite buffers if any.
  45
  46    ------------
  47    -- Create --
  48    ------------
  49
  50    function Create
  51      (Pattern, Value : String;
  52       Size           : Stream_Element_Offset := 1_024) return Buffer
  53    is
  54
  55       subtype SP   is String (1 .. Pattern'Length);
  56       subtype SEAP is Stream_Element_Array (1 .. Pattern'Length);
  57
  58       subtype SV   is String (1 .. Value'Length);
  59       subtype SEAV is Stream_Element_Array (1 .. Value'Length);
  60
  61       function To_SEAP is new Unchecked_Conversion (SP, SEAP);
  62       function To_SEAV is new Unchecked_Conversion (SV, SEAV);
  63
  64    begin
  65       --  Return result (can't be smaller than pattern)
  66
  67       return B : Buffer
  68                    (SEO'Max (Size, SEO (Pattern'Length)),
  69                     SEO (Pattern'Length),
  70                     SEO (Value'Length))
  71       do
  72          B.Pattern := To_SEAP (Pattern);
  73          B.Value   := To_SEAV (Value);
  74          B.Pos_C   := 0;
  75          B.Pos_B   := 0;
  76       end return;
  77    end Create;
  78
  79    ---------------
  80    -- Do_Output --
  81    ---------------
  82
  83    procedure Do_Output
  84      (B      : in out Buffer;
  85       Data   : Stream_Element_Array;
  86       Output : not null access procedure (Data : Stream_Element_Array))
  87    is
  88    begin
  89       if B.Next = null then
  90          Output (Data);
  91       else
  92          Write (B.Next.all, Data, Output);
  93       end if;
  94    end Do_Output;
  95
  96    -----------
  97    -- Flush --
  98    -----------
  99
 100    procedure Flush
 101      (B      : in out Buffer;
 102       Output : not null access procedure (Data : Stream_Element_Array))
 103    is
 104    begin
 105       --  Flush output buffer
 106
 107       if B.Pos_B > 0 then
 108          Do_Output (B, B.Buffer (1 .. B.Pos_B), Output);
 109       end if;
 110
 111       --  Flush current buffer
 112
 113       if B.Pos_C > 0 then
 114          Do_Output (B, B.Current (1 .. B.Pos_C), Output);
 115       end if;
 116
 117       --  Flush linked buffer if any
 118
 119       if B.Next /= null then
 120          Flush (B.Next.all, Output);
 121       end if;
 122
 123       Reset (B);
 124    end Flush;
 125
 126    ----------
 127    -- Link --
 128    ----------
 129
 130    procedure Link (From : in out Buffer; To : Buffer_Ref) is
 131    begin
 132       From.Next := To;
 133    end Link;
 134
 135    -----------
 136    -- Reset --
 137    -----------
 138
 139    procedure Reset (B : in out Buffer) is
 140    begin
 141       B.Pos_B := 0;
 142       B.Pos_C := 0;
 143
 144       if B.Next /= null then
 145          Reset (B.Next.all);
 146       end if;
 147    end Reset;
 148
 149    -------------
 150    -- Rewrite --
 151    -------------
 152
 153    procedure Rewrite
 154      (B      : in out Buffer;
 155       Input  : not null access procedure
 156                  (Buffer : out Stream_Element_Array;
 157                   Last   : out Stream_Element_Offset);
 158       Output : not null access procedure (Data : Stream_Element_Array))
 159    is
 160       Buffer : Stream_Element_Array (1 .. B.Size);
 161       Last   : Stream_Element_Offset;
 162
 163    begin
 164       Rewrite_All : loop
 165          Input (Buffer, Last);
 166          exit Rewrite_All when Last = 0;
 167          Write (B, Buffer (1 .. Last), Output);
 168       end loop Rewrite_All;
 169
 170       Flush (B, Output);
 171    end Rewrite;
 172
 173    ----------
 174    -- Size --
 175    ----------
 176
 177    function Size (B : Buffer) return Natural is
 178    begin
 179       return Natural (B.Pos_B + B.Pos_C);
 180    end Size;
 181
 182    -----------
 183    -- Write --
 184    -----------
 185
 186    procedure Write
 187      (B      : in out Buffer;
 188       Data   : Stream_Element_Array;
 189       Output : not null access procedure (Data : Stream_Element_Array))
 190    is
 191       procedure Need_Space (Size : Stream_Element_Offset);
 192       pragma Inline (Need_Space);
 193
 194       ----------------
 195       -- Need_Space --
 196       ----------------
 197
 198       procedure Need_Space (Size : Stream_Element_Offset) is
 199       begin
 200          if B.Pos_B + Size > B.Size then
 201             Do_Output (B, B.Buffer (1 .. B.Pos_B), Output);
 202             B.Pos_B := 0;
 203          end if;
 204       end Need_Space;
 205
 206    --  Start of processing for Write
 207
 208    begin
 209       if B.Size_Pattern = 0 then
 210          Do_Output (B, Data, Output);
 211
 212       else
 213          for K in Data'Range loop
 214             if Data (K) = B.Pattern (B.Pos_C + 1) then
 215
 216                --  Store possible start of a match
 217
 218                B.Pos_C := B.Pos_C + 1;
 219                B.Current (B.Pos_C) := Data (K);
 220
 221             else
 222                --  Not part of pattern, if a start of a match was found,
 223                --  remove it.
 224
 225                if B.Pos_C /= 0 then
 226                   Need_Space (B.Pos_C);
 227
 228                   B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Pos_C) :=
 229                     B.Current (1 .. B.Pos_C);
 230                   B.Pos_B := B.Pos_B + B.Pos_C;
 231                   B.Pos_C := 0;
 232                end if;
 233
 234                Need_Space (1);
 235                B.Pos_B := B.Pos_B + 1;
 236                B.Buffer (B.Pos_B) := Data (K);
 237             end if;
 238
 239             if B.Pos_C = B.Size_Pattern then
 240
 241                --  The pattern is found
 242
 243                Need_Space (B.Size_Value);
 244
 245                B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Size_Value) := B.Value;
 246                B.Pos_C := 0;
 247                B.Pos_B := B.Pos_B + B.Size_Value;
 248             end if;
 249          end loop;
 250       end if;
 251    end Write;
 252
 253 end GNAT.Rewrite_Data;