path: root/gcc-4.9/gcc/ada/g-decstr.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                    G N A T . D E C O D E _ S T R I N G                   --
--                                                                          --
--                                 S p e c                                  --
--                                                                          --
--                     Copyright (C) 2007-2013, AdaCore                     --
--                                                                          --
-- 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.      --
--                                                                          --
------------------------------------------------------------------------------

--  This package provides a utility routine for converting from an encoded
--  string to a corresponding Wide_String or Wide_Wide_String value.

with Interfaces; use Interfaces;

with System.WCh_Cnv; use System.WCh_Cnv;
with System.WCh_Con; use System.WCh_Con;

package body GNAT.Decode_String is

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Bad;
   pragma No_Return (Bad);
   --  Raise error for bad encoding

   procedure Past_End;
   pragma No_Return (Past_End);
   --  Raise error for off end of string

   ---------
   -- Bad --
   ---------

   procedure Bad is
   begin
      raise Constraint_Error with
        "bad encoding or character out of range";
   end Bad;

   ---------------------------
   -- Decode_Wide_Character --
   ---------------------------

   procedure Decode_Wide_Character
     (Input  : String;
      Ptr    : in out Natural;
      Result : out Wide_Character)
   is
      Char : Wide_Wide_Character;
   begin
      Decode_Wide_Wide_Character (Input, Ptr, Char);

      if Wide_Wide_Character'Pos (Char) > 16#FFFF# then
         Bad;
      else
         Result := Wide_Character'Val (Wide_Wide_Character'Pos (Char));
      end if;
   end Decode_Wide_Character;

   ------------------------
   -- Decode_Wide_String --
   ------------------------

   function Decode_Wide_String (S : String) return Wide_String is
      Result : Wide_String (1 .. S'Length);
      Length : Natural;
   begin
      Decode_Wide_String (S, Result, Length);
      return Result (1 .. Length);
   end Decode_Wide_String;

   procedure Decode_Wide_String
     (S      : String;
      Result : out Wide_String;
      Length : out Natural)
   is
      Ptr : Natural;

   begin
      Ptr := S'First;
      Length := 0;
      while Ptr <= S'Last loop
         if Length >= Result'Last then
            Past_End;
         end if;

         Length := Length + 1;
         Decode_Wide_Character (S, Ptr, Result (Length));
      end loop;
   end Decode_Wide_String;

   --------------------------------
   -- Decode_Wide_Wide_Character --
   --------------------------------

   procedure Decode_Wide_Wide_Character
     (Input  : String;
      Ptr    : in out Natural;
      Result : out Wide_Wide_Character)
   is
      C : Character;

      function In_Char return Character;
      pragma Inline (In_Char);
      --  Function to get one input character

      -------------
      -- In_Char --
      -------------

      function In_Char return Character is
      begin
         if Ptr <= Input'Last then
            Ptr := Ptr + 1;
            return Input (Ptr - 1);
         else
            Past_End;
         end if;
      end In_Char;

   --  Start of processing for Decode_Wide_Wide_Character

   begin
      C := In_Char;

      --  Special fast processing for UTF-8 case

      if Encoding_Method = WCEM_UTF8 then
         UTF8 : declare
            U : Unsigned_32;
            W : Unsigned_32;

            procedure Get_UTF_Byte;
            pragma Inline (Get_UTF_Byte);
            --  Used to interpret 2#10xxxxxx# continuation byte in UTF-8 mode.
            --  Reads a byte, and raises CE if the first two bits are not 10.
            --  Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits.

            ------------------
            -- Get_UTF_Byte --
            ------------------

            procedure Get_UTF_Byte is
            begin
               U := Unsigned_32 (Character'Pos (In_Char));

               if (U and 2#11000000#) /= 2#10_000000# then
                  Bad;
               end if;

               W := Shift_Left (W, 6) or (U and 2#00111111#);
            end Get_UTF_Byte;

         --  Start of processing for UTF8 case

         begin
            --  Note: for details of UTF8 encoding see RFC 3629

            U := Unsigned_32 (Character'Pos (C));

            --  16#00_0000#-16#00_007F#: 0xxxxxxx

            if (U and 2#10000000#) = 2#00000000# then
               Result := Wide_Wide_Character'Val (Character'Pos (C));

            --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx

            elsif (U and 2#11100000#) = 2#110_00000# then
               W := U and 2#00011111#;
               Get_UTF_Byte;

               if W not in 16#00_0080# .. 16#00_07FF# then
                  Bad;
               end if;

               Result := Wide_Wide_Character'Val (W);

            --  16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx

            elsif (U and 2#11110000#) = 2#1110_0000# then
               W := U and 2#00001111#;
               Get_UTF_Byte;
               Get_UTF_Byte;

               if W not in 16#00_0800# .. 16#00_FFFF# then
                  Bad;
               end if;

               Result := Wide_Wide_Character'Val (W);

            --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx

            elsif (U and 2#11111000#) = 2#11110_000# then
               W := U and 2#00000111#;

               for K in 1 .. 3 loop
                  Get_UTF_Byte;
               end loop;

               if W not in 16#01_0000# .. 16#10_FFFF# then
                  Bad;
               end if;

               Result := Wide_Wide_Character'Val (W);

            --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
            --                               10xxxxxx 10xxxxxx

            elsif (U and 2#11111100#) = 2#111110_00# then
               W := U and 2#00000011#;

               for K in 1 .. 4 loop
                  Get_UTF_Byte;
               end loop;

               if W not in 16#0020_0000# .. 16#03FF_FFFF# then
                  Bad;
               end if;

               Result := Wide_Wide_Character'Val (W);

            --  All other cases are invalid, note that this includes:

            --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
            --                               10xxxxxx 10xxxxxx 10xxxxxx

            --  since Wide_Wide_Character does not include code values
            --  greater than 16#03FF_FFFF#.

            else
               Bad;
            end if;
         end UTF8;

      --  All encoding functions other than UTF-8

      else
         Non_UTF8 : declare
            function Char_Sequence_To_UTF is
              new Char_Sequence_To_UTF_32 (In_Char);

         begin
            --  For brackets, must test for specific case of [ not followed by
            --  quotation, where we must not call Char_Sequence_To_UTF, but
            --  instead just return the bracket unchanged.

            if Encoding_Method = WCEM_Brackets
              and then C = '['
              and then (Ptr > Input'Last or else Input (Ptr) /= '"')
            then
               Result := '[';

            --  All other cases including [" with Brackets

            else
               Result :=
                 Wide_Wide_Character'Val
                   (Char_Sequence_To_UTF (C, Encoding_Method));
            end if;
         end Non_UTF8;
      end if;
   end Decode_Wide_Wide_Character;

   -----------------------------
   -- Decode_Wide_Wide_String --
   -----------------------------

   function Decode_Wide_Wide_String (S : String) return Wide_Wide_String is
      Result : Wide_Wide_String (1 .. S'Length);
      Length : Natural;
   begin
      Decode_Wide_Wide_String (S, Result, Length);
      return Result (1 .. Length);
   end Decode_Wide_Wide_String;

   procedure Decode_Wide_Wide_String
     (S      : String;
      Result : out Wide_Wide_String;
      Length : out Natural)
   is
      Ptr : Natural;

   begin
      Ptr := S'First;
      Length := 0;
      while Ptr <= S'Last loop
         if Length >= Result'Last then
            Past_End;
         end if;

         Length := Length + 1;
         Decode_Wide_Wide_Character (S, Ptr, Result (Length));
      end loop;
   end Decode_Wide_Wide_String;

   -------------------------
   -- Next_Wide_Character --
   -------------------------

   procedure Next_Wide_Character (Input : String; Ptr : in out Natural) is
      Discard : Wide_Character;
      pragma Unreferenced (Discard);
   begin
      Decode_Wide_Character (Input, Ptr, Discard);
   end Next_Wide_Character;

   ------------------------------
   -- Next_Wide_Wide_Character --
   ------------------------------

   procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is
      Discard : Wide_Wide_Character;
      pragma Unreferenced (Discard);
   begin
      Decode_Wide_Wide_Character (Input, Ptr, Discard);
   end Next_Wide_Wide_Character;

   --------------
   -- Past_End --
   --------------

   procedure Past_End is
   begin
      raise Constraint_Error with "past end of string";
   end Past_End;

   -------------------------
   -- Prev_Wide_Character --
   -------------------------

   procedure Prev_Wide_Character (Input : String; Ptr : in out Natural) is
   begin
      if Ptr > Input'Last + 1 then
         Past_End;
      end if;

      --  Special efficient encoding for UTF-8 case

      if Encoding_Method = WCEM_UTF8 then
         UTF8 : declare
            U : Unsigned_32;

            procedure Getc;
            pragma Inline (Getc);
            --  Gets the character at Input (Ptr - 1) and returns code in U as
            --  Unsigned_32 value. On return Ptr is decremented by one.

            procedure Skip_UTF_Byte;
            pragma Inline (Skip_UTF_Byte);
            --  Checks that U is 2#10xxxxxx# and then calls Get

            ----------
            -- Getc --
            ----------

            procedure Getc is
            begin
               if Ptr <= Input'First then
                  Past_End;
               else
                  Ptr := Ptr - 1;
                  U := Unsigned_32 (Character'Pos (Input (Ptr)));
               end if;
            end Getc;

            -------------------
            -- Skip_UTF_Byte --
            -------------------

            procedure Skip_UTF_Byte is
            begin
               if (U and 2#11000000#) = 2#10_000000# then
                  Getc;
               else
                  Bad;
               end if;
            end Skip_UTF_Byte;

         --  Start of processing for UTF-8 case

         begin
            --  16#00_0000#-16#00_007F#: 0xxxxxxx

            Getc;

            if (U and 2#10000000#) = 2#00000000# then
               return;

            --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx

            else
               Skip_UTF_Byte;

               if (U and 2#11100000#) = 2#110_00000# then
                  return;

               --  16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx

               else
                  Skip_UTF_Byte;

                  if (U and 2#11110000#) = 2#1110_0000# then
                     return;

                     --  Any other code is invalid, note that this includes:

                     --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx
                     --                           10xxxxxx

                     --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx
                     --                               10xxxxxx 10xxxxxx
                     --                               10xxxxxx

                     --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx
                     --                               10xxxxxx 10xxxxxx
                     --                               10xxxxxx 10xxxxxx

                     --  since Wide_Character does not allow codes > 16#FFFF#

                  else
                     Bad;
                  end if;
               end if;
            end if;
         end UTF8;

      --  Special efficient encoding for brackets case

      elsif Encoding_Method = WCEM_Brackets then
         Brackets : declare
            P : Natural;
            S : Natural;

         begin
            --  See if we have "] at end positions

            if Ptr > Input'First + 1
              and then Input (Ptr - 1) = ']'
              and then Input (Ptr - 2) = '"'
            then
               P := Ptr - 2;

               --  Loop back looking for [" at start

               while P >= Ptr - 10 loop
                  if P <= Input'First + 1 then
                     Bad;

                  elsif Input (P - 1) = '"'
                    and then Input (P - 2) = '['
                  then
                     --  Found ["..."], scan forward to check it

                     S := P - 2;
                     P := S;
                     Next_Wide_Character (Input, P);

                     --  OK if at original pointer, else error

                     if P = Ptr then
                        Ptr := S;
                        return;
                     else
                        Bad;
                     end if;
                  end if;

                  P := P - 1;
               end loop;

               --  Falling through loop means more than 8 chars between the
               --  enclosing brackets (or simply a missing left bracket)

               Bad;

            --  Here if no bracket sequence present

            else
               if Ptr = Input'First then
                  Past_End;
               else
                  Ptr := Ptr - 1;
               end if;
            end if;
         end Brackets;

      --  Non-UTF-8/Brackets. These are the inefficient cases where we have to
      --  go to the start of the string and skip forwards till Ptr matches.

      else
         Non_UTF_Brackets : declare
            Discard : Wide_Character;
            PtrS    : Natural;
            PtrP    : Natural;

         begin
            PtrS := Input'First;

            if Ptr <= PtrS then
               Past_End;
            end if;

            loop
               PtrP := PtrS;
               Decode_Wide_Character (Input, PtrS, Discard);

               if PtrS = Ptr then
                  Ptr := PtrP;
                  return;

               elsif PtrS > Ptr then
                  Bad;
               end if;
            end loop;

         exception
            when Constraint_Error =>
               Bad;
         end Non_UTF_Brackets;
      end if;
   end Prev_Wide_Character;

   ------------------------------
   -- Prev_Wide_Wide_Character --
   ------------------------------

   procedure Prev_Wide_Wide_Character (Input : String; Ptr : in out Natural) is
   begin
      if Ptr > Input'Last + 1 then
         Past_End;
      end if;

      --  Special efficient encoding for UTF-8 case

      if Encoding_Method = WCEM_UTF8 then
         UTF8 : declare
            U : Unsigned_32;

            procedure Getc;
            pragma Inline (Getc);
            --  Gets the character at Input (Ptr - 1) and returns code in U as
            --  Unsigned_32 value. On return Ptr is decremented by one.

            procedure Skip_UTF_Byte;
            pragma Inline (Skip_UTF_Byte);
            --  Checks that U is 2#10xxxxxx# and then calls Get

            ----------
            -- Getc --
            ----------

            procedure Getc is
            begin
               if Ptr <= Input'First then
                  Past_End;
               else
                  Ptr := Ptr - 1;
                  U := Unsigned_32 (Character'Pos (Input (Ptr)));
               end if;
            end Getc;

            -------------------
            -- Skip_UTF_Byte --
            -------------------

            procedure Skip_UTF_Byte is
            begin
               if (U and 2#11000000#) = 2#10_000000# then
                  Getc;
               else
                  Bad;
               end if;
            end Skip_UTF_Byte;

         --  Start of processing for UTF-8 case

         begin
            --  16#00_0000#-16#00_007F#: 0xxxxxxx

            Getc;

            if (U and 2#10000000#) = 2#00000000# then
               return;

            --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx

            else
               Skip_UTF_Byte;

               if (U and 2#11100000#) = 2#110_00000# then
                  return;

               --  16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx

               else
                  Skip_UTF_Byte;

                  if (U and 2#11110000#) = 2#1110_0000# then
                     return;

                  --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx
                  --                           10xxxxxx

                  else
                     Skip_UTF_Byte;

                     if (U and 2#11111000#) = 2#11110_000# then
                        return;

                     --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx
                     --                               10xxxxxx 10xxxxxx
                     --                               10xxxxxx

                     else
                        Skip_UTF_Byte;

                        if (U and 2#11111100#) = 2#111110_00# then
                           return;

                        --  Any other code is invalid, note that this includes:

                        --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx
                        --                               10xxxxxx 10xxxxxx
                        --                               10xxxxxx 10xxxxxx

                        --  since Wide_Wide_Character does not allow codes
                        --  greater than 16#03FF_FFFF#

                        else
                           Bad;
                        end if;
                     end if;
                  end if;
               end if;
            end if;
         end UTF8;

      --  Special efficient encoding for brackets case

      elsif Encoding_Method = WCEM_Brackets then
         Brackets : declare
            P : Natural;
            S : Natural;

         begin
            --  See if we have "] at end positions

            if Ptr > Input'First + 1
              and then Input (Ptr - 1) = ']'
              and then Input (Ptr - 2) = '"'
            then
               P := Ptr - 2;

               --  Loop back looking for [" at start

               while P >= Ptr - 10 loop
                  if P <= Input'First + 1 then
                     Bad;

                  elsif Input (P - 1) = '"'
                    and then Input (P - 2) = '['
                  then
                     --  Found ["..."], scan forward to check it

                     S := P - 2;
                     P := S;
                     Next_Wide_Wide_Character (Input, P);

                     --  OK if at original pointer, else error

                     if P = Ptr then
                        Ptr := S;
                        return;
                     else
                        Bad;
                     end if;
                  end if;

                  P := P - 1;
               end loop;

               --  Falling through loop means more than 8 chars between the
               --  enclosing brackets (or simply a missing left bracket)

               Bad;

            --  Here if no bracket sequence present

            else
               if Ptr = Input'First then
                  Past_End;
               else
                  Ptr := Ptr - 1;
               end if;
            end if;
         end Brackets;

      --  Non-UTF-8/Brackets. These are the inefficient cases where we have to
      --  go to the start of the string and skip forwards till Ptr matches.

      else
         Non_UTF8_Brackets : declare
            Discard : Wide_Wide_Character;
            PtrS    : Natural;
            PtrP    : Natural;

         begin
            PtrS := Input'First;

            if Ptr <= PtrS then
               Past_End;
            end if;

            loop
               PtrP := PtrS;
               Decode_Wide_Wide_Character (Input, PtrS, Discard);

               if PtrS = Ptr then
                  Ptr := PtrP;
                  return;

               elsif PtrS > Ptr then
                  Bad;
               end if;
            end loop;

         exception
            when Constraint_Error =>
               Bad;
         end Non_UTF8_Brackets;
      end if;
   end Prev_Wide_Wide_Character;

   --------------------------
   -- Validate_Wide_String --
   --------------------------

   function Validate_Wide_String (S : String) return Boolean is
      Ptr : Natural;

   begin
      Ptr := S'First;
      while Ptr <= S'Last loop
         Next_Wide_Character (S, Ptr);
      end loop;

      return True;

   exception
      when Constraint_Error =>
         return False;
   end Validate_Wide_String;

   -------------------------------
   -- Validate_Wide_Wide_String --
   -------------------------------

   function Validate_Wide_Wide_String (S : String) return Boolean is
      Ptr : Natural;

   begin
      Ptr := S'First;
      while Ptr <= S'Last loop
         Next_Wide_Wide_Character (S, Ptr);
      end loop;

      return True;

   exception
      when Constraint_Error =>
         return False;
   end Validate_Wide_Wide_String;

end GNAT.Decode_String;