aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/g-encstr.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/g-encstr.adb')
-rw-r--r--gcc/ada/g-encstr.adb258
1 files changed, 0 insertions, 258 deletions
diff --git a/gcc/ada/g-encstr.adb b/gcc/ada/g-encstr.adb
deleted file mode 100644
index 80ca6d0..0000000
--- a/gcc/ada/g-encstr.adb
+++ /dev/null
@@ -1,258 +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-2012, 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 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;
generated by cgit v1.1 at 2025-04-09 22:39:05 +0000