diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/g-encstr.adb')
| -rwxr-xr-x | gcc-4.4.0/gcc/ada/g-encstr.adb | 260 |
1 files changed, 260 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/g-encstr.adb b/gcc-4.4.0/gcc/ada/g-encstr.adb new file mode 100755 index 000000000..6f1411693 --- /dev/null +++ b/gcc-4.4.0/gcc/ada/g-encstr.adb @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E N C O D E _ S T R I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_Cnv; use System.WCh_Cnv; + +package body GNAT.Encode_String is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Bad; + pragma No_Return (Bad); + -- Raise error for bad character code + + procedure Past_End; + pragma No_Return (Past_End); + -- Raise error for off end of string + + --------- + -- Bad -- + --------- + + procedure Bad is + begin + raise Constraint_Error with + "character cannot be encoded with given Encoding_Method"; + end Bad; + + ------------------------ + -- Encode_Wide_String -- + ------------------------ + + function Encode_Wide_String (S : Wide_String) return String is + Long : constant Natural := WC_Longest_Sequences (Encoding_Method); + Result : String (1 .. S'Length * Long); + Length : Natural; + begin + Encode_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Encode_Wide_String; + + procedure Encode_Wide_String + (S : Wide_String; + Result : out String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + for J in S'Range loop + Encode_Wide_Character (S (J), Result, Ptr); + end loop; + + Length := Ptr - S'First; + end Encode_Wide_String; + + ----------------------------- + -- Encode_Wide_Wide_String -- + ----------------------------- + + function Encode_Wide_Wide_String (S : Wide_Wide_String) return String is + Long : constant Natural := WC_Longest_Sequences (Encoding_Method); + Result : String (1 .. S'Length * Long); + Length : Natural; + begin + Encode_Wide_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Encode_Wide_Wide_String; + + procedure Encode_Wide_Wide_String + (S : Wide_Wide_String; + Result : out String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + for J in S'Range loop + Encode_Wide_Wide_Character (S (J), Result, Ptr); + end loop; + + Length := Ptr - S'First; + end Encode_Wide_Wide_String; + + --------------------------- + -- Encode_Wide_Character -- + --------------------------- + + procedure Encode_Wide_Character + (Char : Wide_Character; + Result : in out String; + Ptr : in out Natural) + is + begin + Encode_Wide_Wide_Character + (Wide_Wide_Character'Val (Wide_Character'Pos (Char)), Result, Ptr); + + exception + when Constraint_Error => + Bad; + end Encode_Wide_Character; + + -------------------------------- + -- Encode_Wide_Wide_Character -- + -------------------------------- + + procedure Encode_Wide_Wide_Character + (Char : Wide_Wide_Character; + Result : in out String; + Ptr : in out Natural) + is + U : Unsigned_32; + + procedure Out_Char (C : Character); + pragma Inline (Out_Char); + -- Procedure to store one character for instantiation below + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + if Ptr > Result'Last then + Past_End; + else + Result (Ptr) := C; + Ptr := Ptr + 1; + end if; + end Out_Char; + + -- Start of processing for Encode_Wide_Wide_Character; + + begin + -- Efficient code for UTF-8 case + + if Encoding_Method = WCEM_UTF8 then + + -- Note: for details of UTF8 encoding see RFC 3629 + + U := Unsigned_32 (Wide_Wide_Character'Pos (Char)); + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + if U <= 16#00_007F# then + Out_Char (Character'Val (U)); + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif U <= 16#00_07FF# then + Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#00_FFFF# then + Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#10_FFFF# then + Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif U <= 16#03FF_FFFF# then + Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- All other cases are invalid character codes, not this includes: + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx 10xxxxxx + + -- since Wide_Wide_Character values cannot exceed 16#3F_FFFF# + + else + Bad; + end if; + + -- All encoding methods other than UTF-8 + + else + Non_UTF8 : declare + procedure UTF_32_To_String is + new UTF_32_To_Char_Sequence (Out_Char); + -- Instantiate conversion procedure with above Out_Char routine + + begin + UTF_32_To_String + (UTF_32_Code (Wide_Wide_Character'Pos (Char)), Encoding_Method); + + exception + when Constraint_Error => + Bad; + end Non_UTF8; + end if; + end Encode_Wide_Wide_Character; + + -------------- + -- Past_End -- + -------------- + + procedure Past_End is + begin + raise Constraint_Error with "past end of string"; + end Past_End; + +end GNAT.Encode_String; |