1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . W C H _ W T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with System.WCh_Con; use System.WCh_Con; 33with System.WCh_Cnv; use System.WCh_Cnv; 34 35package body System.WCh_WtS is 36 37 ----------------------- 38 -- Local Subprograms -- 39 ----------------------- 40 41 procedure Store_UTF_32_Character 42 (U : UTF_32_Code; 43 S : out String; 44 P : in out Integer; 45 EM : WC_Encoding_Method); 46 -- Stores the string representation of the wide or wide wide character 47 -- whose code is given as U, starting at S (P + 1). P is incremented to 48 -- point to the last character stored. Raises CE if character cannot be 49 -- stored using the given encoding method. 50 51 ---------------------------- 52 -- Store_UTF_32_Character -- 53 ---------------------------- 54 55 procedure Store_UTF_32_Character 56 (U : UTF_32_Code; 57 S : out String; 58 P : in out Integer; 59 EM : WC_Encoding_Method) 60 is 61 procedure Out_Char (C : Character); 62 pragma Inline (Out_Char); 63 -- Procedure to increment P and store C at S (P) 64 65 procedure Store_Chars is new UTF_32_To_Char_Sequence (Out_Char); 66 67 -------------- 68 -- Out_Char -- 69 -------------- 70 71 procedure Out_Char (C : Character) is 72 begin 73 P := P + 1; 74 S (P) := C; 75 end Out_Char; 76 77 begin 78 Store_Chars (U, EM); 79 end Store_UTF_32_Character; 80 81 --------------------------- 82 -- Wide_String_To_String -- 83 --------------------------- 84 85 function Wide_String_To_String 86 (S : Wide_String; 87 EM : WC_Encoding_Method) return String 88 is 89 R : String (S'First .. S'First + 5 * S'Length); -- worst case length 90 RP : Natural; 91 92 begin 93 RP := R'First - 1; 94 for SP in S'Range loop 95 Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); 96 end loop; 97 98 return R (R'First .. RP); 99 end Wide_String_To_String; 100 101 -------------------------------- 102 -- Wide_Wide_String_To_String -- 103 -------------------------------- 104 105 function Wide_Wide_String_To_String 106 (S : Wide_Wide_String; 107 EM : WC_Encoding_Method) return String 108 is 109 R : String (S'First .. S'First + 7 * S'Length); -- worst case length 110 RP : Natural; 111 112 begin 113 RP := R'First - 1; 114 115 for SP in S'Range loop 116 Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); 117 end loop; 118 119 return R (R'First .. RP); 120 end Wide_Wide_String_To_String; 121 122end System.WCh_WtS; 123