1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . W C H _ S T W -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2009, 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_StW is 36 37 ----------------------- 38 -- Local Subprograms -- 39 ----------------------- 40 41 procedure Get_Next_Code 42 (S : String; 43 P : in out Natural; 44 V : out UTF_32_Code; 45 EM : WC_Encoding_Method); 46 -- Scans next character starting at S(P) and returns its value in V. On 47 -- exit P is updated past the last character read. Raises Constraint_Error 48 -- if the string is not well formed. Raises Constraint_Error if the code 49 -- value is greater than 16#7FFF_FFFF#. On entry P <= S'Last. 50 51 ------------------- 52 -- Get_Next_Code -- 53 ------------------- 54 55 procedure Get_Next_Code 56 (S : String; 57 P : in out Natural; 58 V : out UTF_32_Code; 59 EM : WC_Encoding_Method) 60 is 61 function In_Char return Character; 62 -- Function to return a character, bumping P, raises Constraint_Error 63 -- if P > S'Last on entry. 64 65 function Get_UTF_32 is new Char_Sequence_To_UTF_32 (In_Char); 66 -- Function to get next UFT_32 value 67 68 ------------- 69 -- In_Char -- 70 ------------- 71 72 function In_Char return Character is 73 begin 74 if P > S'Last then 75 raise Constraint_Error with "badly formed wide character code"; 76 else 77 P := P + 1; 78 return S (P - 1); 79 end if; 80 end In_Char; 81 82 -- Start of processing for Get_Next_Code 83 84 begin 85 -- Check for wide character encoding 86 87 case EM is 88 when WCEM_Hex => 89 if S (P) = ASCII.ESC then 90 V := Get_UTF_32 (In_Char, EM); 91 return; 92 end if; 93 94 when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC | WCEM_UTF8 => 95 if S (P) >= Character'Val (16#80#) then 96 V := Get_UTF_32 (In_Char, EM); 97 return; 98 end if; 99 100 when WCEM_Brackets => 101 if P + 2 <= S'Last 102 and then S (P) = '[' 103 and then S (P + 1) = '"' 104 and then S (P + 2) /= '"' 105 then 106 V := Get_UTF_32 (In_Char, EM); 107 return; 108 end if; 109 end case; 110 111 -- If it is not a wide character code, just get it 112 113 V := Character'Pos (S (P)); 114 P := P + 1; 115 end Get_Next_Code; 116 117 --------------------------- 118 -- String_To_Wide_String -- 119 --------------------------- 120 121 procedure String_To_Wide_String 122 (S : String; 123 R : out Wide_String; 124 L : out Natural; 125 EM : System.WCh_Con.WC_Encoding_Method) 126 is 127 SP : Natural; 128 V : UTF_32_Code; 129 130 begin 131 pragma Assert (S'First = 1); 132 133 SP := S'First; 134 L := 0; 135 while SP <= S'Last loop 136 Get_Next_Code (S, SP, V, EM); 137 138 if V > 16#FFFF# then 139 raise Constraint_Error with 140 "out of range value for wide character"; 141 end if; 142 143 L := L + 1; 144 R (L) := Wide_Character'Val (V); 145 end loop; 146 end String_To_Wide_String; 147 148 -------------------------------- 149 -- String_To_Wide_Wide_String -- 150 -------------------------------- 151 152 procedure String_To_Wide_Wide_String 153 (S : String; 154 R : out Wide_Wide_String; 155 L : out Natural; 156 EM : System.WCh_Con.WC_Encoding_Method) 157 is 158 pragma Assert (S'First = 1); 159 160 SP : Natural; 161 V : UTF_32_Code; 162 163 begin 164 SP := S'First; 165 L := 0; 166 while SP <= S'Last loop 167 Get_Next_Code (S, SP, V, EM); 168 L := L + 1; 169 R (L) := Wide_Wide_Character'Val (V); 170 end loop; 171 end String_To_Wide_Wide_String; 172 173end System.WCh_StW; 174