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-2019, 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 Max_Chars : constant Natural := WC_Longest_Sequences (EM); 90 91 Result : String (S'First .. S'First + Max_Chars * S'Length); 92 Result_Idx : Natural; 93 94 begin 95 Result_Idx := Result'First - 1; 96 97 for S_Idx in S'Range loop 98 Store_UTF_32_Character 99 (U => Wide_Character'Pos (S (S_Idx)), 100 S => Result, 101 P => Result_Idx, 102 EM => EM); 103 end loop; 104 105 return Result (Result'First .. Result_Idx); 106 end Wide_String_To_String; 107 108 -------------------------------- 109 -- Wide_Wide_String_To_String -- 110 -------------------------------- 111 112 function Wide_Wide_String_To_String 113 (S : Wide_Wide_String; 114 EM : WC_Encoding_Method) return String 115 is 116 Max_Chars : constant Natural := WC_Longest_Sequences (EM); 117 118 Result : String (S'First .. S'First + Max_Chars * S'Length); 119 Result_Idx : Natural; 120 121 begin 122 Result_Idx := Result'First - 1; 123 124 for S_Idx in S'Range loop 125 Store_UTF_32_Character 126 (U => Wide_Wide_Character'Pos (S (S_Idx)), 127 S => Result, 128 P => Result_Idx, 129 EM => EM); 130 end loop; 131 132 return Result (Result'First .. Result_Idx); 133 end Wide_Wide_String_To_String; 134 135end System.WCh_WtS; 136