This repository has been archived on 2024-12-16. You can view files and clone it, but cannot push or open issues or pull requests.
CodeBlocksPortable/MinGW/lib/gcc/mingw32/6.3.0/adainclude/g-rewdat.adb

254 lines
7.5 KiB
Ada

-----------------------------------------------------------------------------
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . R E W R I T E _ D A T A --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014, 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- --
-- ware Foundation; either version 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Unchecked_Conversion;
package body GNAT.Rewrite_Data is
use Ada;
subtype SEO is Stream_Element_Offset;
procedure Do_Output
(B : in out Buffer;
Data : Stream_Element_Array;
Output : not null access procedure (Data : Stream_Element_Array));
-- Do the actual output. This ensures that we properly send the data
-- through linked rewrite buffers if any.
------------
-- Create --
------------
function Create
(Pattern, Value : String;
Size : Stream_Element_Offset := 1_024) return Buffer
is
subtype SP is String (1 .. Pattern'Length);
subtype SEAP is Stream_Element_Array (1 .. Pattern'Length);
subtype SV is String (1 .. Value'Length);
subtype SEAV is Stream_Element_Array (1 .. Value'Length);
function To_SEAP is new Unchecked_Conversion (SP, SEAP);
function To_SEAV is new Unchecked_Conversion (SV, SEAV);
begin
-- Return result (can't be smaller than pattern)
return B : Buffer
(SEO'Max (Size, SEO (Pattern'Length)),
SEO (Pattern'Length),
SEO (Value'Length))
do
B.Pattern := To_SEAP (Pattern);
B.Value := To_SEAV (Value);
B.Pos_C := 0;
B.Pos_B := 0;
end return;
end Create;
---------------
-- Do_Output --
---------------
procedure Do_Output
(B : in out Buffer;
Data : Stream_Element_Array;
Output : not null access procedure (Data : Stream_Element_Array))
is
begin
if B.Next = null then
Output (Data);
else
Write (B.Next.all, Data, Output);
end if;
end Do_Output;
-----------
-- Flush --
-----------
procedure Flush
(B : in out Buffer;
Output : not null access procedure (Data : Stream_Element_Array))
is
begin
-- Flush output buffer
if B.Pos_B > 0 then
Do_Output (B, B.Buffer (1 .. B.Pos_B), Output);
end if;
-- Flush current buffer
if B.Pos_C > 0 then
Do_Output (B, B.Current (1 .. B.Pos_C), Output);
end if;
-- Flush linked buffer if any
if B.Next /= null then
Flush (B.Next.all, Output);
end if;
Reset (B);
end Flush;
----------
-- Link --
----------
procedure Link (From : in out Buffer; To : Buffer_Ref) is
begin
From.Next := To;
end Link;
-----------
-- Reset --
-----------
procedure Reset (B : in out Buffer) is
begin
B.Pos_B := 0;
B.Pos_C := 0;
if B.Next /= null then
Reset (B.Next.all);
end if;
end Reset;
-------------
-- Rewrite --
-------------
procedure Rewrite
(B : in out Buffer;
Input : not null access procedure
(Buffer : out Stream_Element_Array;
Last : out Stream_Element_Offset);
Output : not null access procedure (Data : Stream_Element_Array))
is
Buffer : Stream_Element_Array (1 .. B.Size);
Last : Stream_Element_Offset;
begin
Rewrite_All : loop
Input (Buffer, Last);
exit Rewrite_All when Last = 0;
Write (B, Buffer (1 .. Last), Output);
end loop Rewrite_All;
Flush (B, Output);
end Rewrite;
----------
-- Size --
----------
function Size (B : Buffer) return Natural is
begin
return Natural (B.Pos_B + B.Pos_C);
end Size;
-----------
-- Write --
-----------
procedure Write
(B : in out Buffer;
Data : Stream_Element_Array;
Output : not null access procedure (Data : Stream_Element_Array))
is
procedure Need_Space (Size : Stream_Element_Offset);
pragma Inline (Need_Space);
----------------
-- Need_Space --
----------------
procedure Need_Space (Size : Stream_Element_Offset) is
begin
if B.Pos_B + Size > B.Size then
Do_Output (B, B.Buffer (1 .. B.Pos_B), Output);
B.Pos_B := 0;
end if;
end Need_Space;
-- Start of processing for Write
begin
if B.Size_Pattern = 0 then
Do_Output (B, Data, Output);
else
for K in Data'Range loop
if Data (K) = B.Pattern (B.Pos_C + 1) then
-- Store possible start of a match
B.Pos_C := B.Pos_C + 1;
B.Current (B.Pos_C) := Data (K);
else
-- Not part of pattern, if a start of a match was found,
-- remove it.
if B.Pos_C /= 0 then
Need_Space (B.Pos_C);
B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Pos_C) :=
B.Current (1 .. B.Pos_C);
B.Pos_B := B.Pos_B + B.Pos_C;
B.Pos_C := 0;
end if;
Need_Space (1);
B.Pos_B := B.Pos_B + 1;
B.Buffer (B.Pos_B) := Data (K);
end if;
if B.Pos_C = B.Size_Pattern then
-- The pattern is found
Need_Space (B.Size_Value);
B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Size_Value) := B.Value;
B.Pos_C := 0;
B.Pos_B := B.Pos_B + B.Size_Value;
end if;
end loop;
end if;
end Write;
end GNAT.Rewrite_Data;