Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/libgnat/g-rewdat.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/libgnat/g-rewdat.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,253 @@ +----------------------------------------------------------------------------- +-- 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-2017, 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;