diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/g-encstr.adb')
| -rwxr-xr-x | gcc-4.4.3/gcc/ada/g-encstr.adb | 260 |
1 files changed, 0 insertions, 260 deletions
diff --git a/gcc-4.4.3/gcc/ada/g-encstr.adb b/gcc-4.4.3/gcc/ada/g-encstr.adb deleted file mode 100755 index 6f1411693..000000000 --- a/gcc-4.4.3/gcc/ada/g-encstr.adb +++ /dev/null @@ -1,260 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |