1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- W I D E C H A R -- 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 32-- Note: this package uses the generic subprograms in System.WCh_Cnv, which 33-- completely encapsulate the set of wide character encoding methods, so no 34-- modifications are required when adding new encoding methods. 35 36with Opt; use Opt; 37 38with System.WCh_Cnv; use System.WCh_Cnv; 39with System.WCh_Con; use System.WCh_Con; 40 41package body Widechar is 42 43 --------------------------- 44 -- Is_Start_Of_Wide_Char -- 45 --------------------------- 46 47 function Is_Start_Of_Wide_Char 48 (S : Source_Buffer_Ptr; 49 P : Source_Ptr) return Boolean 50 is 51 begin 52 case Wide_Character_Encoding_Method is 53 54 -- For Hex mode, just test for an ESC character. The ESC character 55 -- cannot appear in any other context in a legal Ada program. 56 57 when WCEM_Hex => 58 return S (P) = ASCII.ESC; 59 60 -- For brackets, just test ["x where x is a hex character. This is 61 -- sufficient test, since this sequence cannot otherwise appear in a 62 -- legal Ada program. 63 64 when WCEM_Brackets => 65 return P <= S'Last - 2 66 and then S (P) = '[' 67 and then S (P + 1) = '"' 68 and then (S (P + 2) in '0' .. '9' 69 or else 70 S (P + 2) in 'a' .. 'f' 71 or else 72 S (P + 2) in 'A' .. 'F'); 73 74 -- All other encoding methods use the upper bit set in the first 75 -- character to uniquely represent a wide character. 76 77 when WCEM_EUC 78 | WCEM_Shift_JIS 79 | WCEM_Upper 80 | WCEM_UTF8 81 => 82 return S (P) >= Character'Val (16#80#); 83 end case; 84 end Is_Start_Of_Wide_Char; 85 86 ----------------- 87 -- Length_Wide -- 88 ----------------- 89 90 function Length_Wide return Nat is 91 begin 92 return WC_Longest_Sequence; 93 end Length_Wide; 94 95 --------------- 96 -- Scan_Wide -- 97 --------------- 98 99 procedure Scan_Wide 100 (S : Source_Buffer_Ptr; 101 P : in out Source_Ptr; 102 C : out Char_Code; 103 Err : out Boolean) 104 is 105 P_Init : constant Source_Ptr := P; 106 Chr : Character; 107 108 function In_Char return Character; 109 -- Function to obtain characters of wide character escape sequence 110 111 ------------- 112 -- In_Char -- 113 ------------- 114 115 function In_Char return Character is 116 begin 117 P := P + 1; 118 return S (P - 1); 119 end In_Char; 120 121 function WC_In is new Char_Sequence_To_UTF_32 (In_Char); 122 123 -- Start of processing for Scan_Wide 124 125 begin 126 Chr := In_Char; 127 128 -- Scan out the wide character. If the first character is a bracket, 129 -- we allow brackets encoding regardless of the standard encoding 130 -- method being used, but otherwise we use this standard method. 131 132 if Chr = '[' then 133 C := Char_Code (WC_In (Chr, WCEM_Brackets)); 134 else 135 C := Char_Code (WC_In (Chr, Wide_Character_Encoding_Method)); 136 end if; 137 138 Err := False; 139 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); 140 141 exception 142 when Constraint_Error => 143 C := Char_Code (0); 144 P := P - 1; 145 Err := True; 146 end Scan_Wide; 147 148 -------------- 149 -- Set_Wide -- 150 -------------- 151 152 procedure Set_Wide 153 (C : Char_Code; 154 S : in out String; 155 P : in out Natural) 156 is 157 procedure Out_Char (C : Character); 158 -- Procedure to store one character of wide character sequence 159 160 -------------- 161 -- Out_Char -- 162 -------------- 163 164 procedure Out_Char (C : Character) is 165 begin 166 P := P + 1; 167 S (P) := C; 168 end Out_Char; 169 170 procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); 171 172 -- Start of processing for Set_Wide 173 174 begin 175 WC_Out (UTF_32_Code (C), Wide_Character_Encoding_Method); 176 end Set_Wide; 177 178 --------------- 179 -- Skip_Wide -- 180 --------------- 181 182 procedure Skip_Wide (S : String; P : in out Natural) is 183 P_Init : constant Natural := P; 184 185 function Skip_Char return Character; 186 -- Function to skip one character of wide character escape sequence 187 188 --------------- 189 -- Skip_Char -- 190 --------------- 191 192 function Skip_Char return Character is 193 begin 194 P := P + 1; 195 return S (P - 1); 196 end Skip_Char; 197 198 function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); 199 200 Discard : UTF_32_Code; 201 pragma Warnings (Off, Discard); 202 203 -- Start of processing for Skip_Wide 204 205 begin 206 Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); 207 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); 208 end Skip_Wide; 209 210 --------------- 211 -- Skip_Wide -- 212 --------------- 213 214 procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is 215 P_Init : constant Source_Ptr := P; 216 217 function Skip_Char return Character; 218 -- Function to skip one character of wide character escape sequence 219 220 --------------- 221 -- Skip_Char -- 222 --------------- 223 224 function Skip_Char return Character is 225 begin 226 P := P + 1; 227 return S (P - 1); 228 end Skip_Char; 229 230 function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); 231 232 Discard : UTF_32_Code; 233 pragma Warnings (Off, Discard); 234 235 -- Start of processing for Skip_Wide 236 237 begin 238 Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); 239 Wide_Char_Byte_Count := Wide_Char_Byte_Count + Nat (P - P_Init - 1); 240 end Skip_Wide; 241 242end Widechar; 243