1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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 Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; 33with Ada.Characters.Conversions; use Ada.Characters.Conversions; 34with Ada.Characters.Handling; use Ada.Characters.Handling; 35with Interfaces.C_Streams; use Interfaces.C_Streams; 36with System.WCh_Con; use System.WCh_Con; 37 38package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is 39 40 ----------------------- 41 -- Local Subprograms -- 42 ----------------------- 43 44 procedure Store_Char 45 (WC : Wide_Wide_Character; 46 Buf : out Wide_Wide_String; 47 Ptr : in out Integer); 48 -- Store a single character in buffer, checking for overflow 49 50 -- These definitions replace the ones in Ada.Characters.Handling, which 51 -- do not seem to work for some strange not understood reason ??? at 52 -- least in the OS/2 version. 53 54 function To_Lower (C : Character) return Character; 55 56 ------------------ 57 -- Get_Enum_Lit -- 58 ------------------ 59 60 procedure Get_Enum_Lit 61 (File : File_Type; 62 Buf : out Wide_Wide_String; 63 Buflen : out Natural) 64 is 65 ch : int; 66 WC : Wide_Wide_Character; 67 68 begin 69 Buflen := 0; 70 Load_Skip (File); 71 ch := Nextc (File); 72 73 -- Character literal case. If the initial character is a quote, then 74 -- we read as far as we can without backup (see ACVC test CE3905L) 75 76 if ch = Character'Pos (''') then 77 Get (File, WC); 78 Store_Char (WC, Buf, Buflen); 79 80 ch := Nextc (File); 81 82 if ch = LM or else ch = EOF then 83 return; 84 end if; 85 86 Get (File, WC); 87 Store_Char (WC, Buf, Buflen); 88 89 ch := Nextc (File); 90 91 if ch /= Character'Pos (''') then 92 return; 93 end if; 94 95 Get (File, WC); 96 Store_Char (WC, Buf, Buflen); 97 98 -- Similarly for identifiers, read as far as we can, in particular, 99 -- do read a trailing underscore (again see ACVC test CE3905L to 100 -- understand why we do this, although it seems somewhat peculiar). 101 102 else 103 -- Identifier must start with a letter. Any wide character value 104 -- outside the normal Latin-1 range counts as a letter for this. 105 106 if ch < 255 and then not Is_Letter (Character'Val (ch)) then 107 return; 108 end if; 109 110 -- If we do have a letter, loop through the characters quitting on 111 -- the first non-identifier character (note that this includes the 112 -- cases of hitting a line mark or page mark). 113 114 loop 115 Get (File, WC); 116 Store_Char (WC, Buf, Buflen); 117 118 ch := Nextc (File); 119 120 exit when ch = EOF; 121 122 if ch = Character'Pos ('_') then 123 exit when Buf (Buflen) = '_'; 124 125 elsif ch = Character'Pos (ASCII.ESC) then 126 null; 127 128 elsif File.WC_Method in WC_Upper_Half_Encoding_Method 129 and then ch > 127 130 then 131 null; 132 133 else 134 exit when not Is_Letter (Character'Val (ch)) 135 and then 136 not Is_Digit (Character'Val (ch)); 137 end if; 138 end loop; 139 end if; 140 end Get_Enum_Lit; 141 142 --------- 143 -- Put -- 144 --------- 145 146 procedure Put 147 (File : File_Type; 148 Item : Wide_Wide_String; 149 Width : Field; 150 Set : Type_Set) 151 is 152 Actual_Width : constant Integer := 153 Integer'Max (Integer (Width), Item'Length); 154 155 begin 156 Check_On_One_Line (File, Actual_Width); 157 158 if Set = Lower_Case and then Item (Item'First) /= ''' then 159 declare 160 Iteml : Wide_Wide_String (Item'First .. Item'Last); 161 162 begin 163 for J in Item'Range loop 164 if Is_Character (Item (J)) then 165 Iteml (J) := 166 To_Wide_Wide_Character 167 (To_Lower (To_Character (Item (J)))); 168 else 169 Iteml (J) := Item (J); 170 end if; 171 end loop; 172 173 Put (File, Iteml); 174 end; 175 176 else 177 Put (File, Item); 178 end if; 179 180 for J in 1 .. Actual_Width - Item'Length loop 181 Put (File, ' '); 182 end loop; 183 end Put; 184 185 ---------- 186 -- Puts -- 187 ---------- 188 189 procedure Puts 190 (To : out Wide_Wide_String; 191 Item : Wide_Wide_String; 192 Set : Type_Set) 193 is 194 Ptr : Natural; 195 196 begin 197 if Item'Length > To'Length then 198 raise Layout_Error; 199 200 else 201 Ptr := To'First; 202 for J in Item'Range loop 203 if Set = Lower_Case 204 and then Item (Item'First) /= ''' 205 and then Is_Character (Item (J)) 206 then 207 To (Ptr) := 208 To_Wide_Wide_Character (To_Lower (To_Character (Item (J)))); 209 else 210 To (Ptr) := Item (J); 211 end if; 212 213 Ptr := Ptr + 1; 214 end loop; 215 216 while Ptr <= To'Last loop 217 To (Ptr) := ' '; 218 Ptr := Ptr + 1; 219 end loop; 220 end if; 221 end Puts; 222 223 ------------------- 224 -- Scan_Enum_Lit -- 225 ------------------- 226 227 procedure Scan_Enum_Lit 228 (From : Wide_Wide_String; 229 Start : out Natural; 230 Stop : out Natural) 231 is 232 WC : Wide_Wide_Character; 233 234 -- Processing for Scan_Enum_Lit 235 236 begin 237 Start := From'First; 238 239 loop 240 if Start > From'Last then 241 raise End_Error; 242 243 elsif Is_Character (From (Start)) 244 and then not Is_Blank (To_Character (From (Start))) 245 then 246 exit; 247 248 else 249 Start := Start + 1; 250 end if; 251 end loop; 252 253 -- Character literal case. If the initial character is a quote, then 254 -- we read as far as we can without backup (see ACVC test CE3905L 255 -- which is for the analogous case for reading from a file). 256 257 if From (Start) = ''' then 258 Stop := Start; 259 260 if Stop = From'Last then 261 raise Data_Error; 262 else 263 Stop := Stop + 1; 264 end if; 265 266 if From (Stop) in ' ' .. '~' 267 or else From (Stop) >= Wide_Wide_Character'Val (16#80#) 268 then 269 if Stop = From'Last then 270 raise Data_Error; 271 else 272 Stop := Stop + 1; 273 274 if From (Stop) = ''' then 275 return; 276 end if; 277 end if; 278 end if; 279 280 raise Data_Error; 281 282 -- Similarly for identifiers, read as far as we can, in particular, 283 -- do read a trailing underscore (again see ACVC test CE3905L to 284 -- understand why we do this, although it seems somewhat peculiar). 285 286 else 287 -- Identifier must start with a letter, any wide character outside 288 -- the normal Latin-1 range is considered a letter for this test. 289 290 if Is_Character (From (Start)) 291 and then not Is_Letter (To_Character (From (Start))) 292 then 293 raise Data_Error; 294 end if; 295 296 -- If we do have a letter, loop through the characters quitting on 297 -- the first non-identifier character (note that this includes the 298 -- cases of hitting a line mark or page mark). 299 300 Stop := Start + 1; 301 while Stop < From'Last loop 302 WC := From (Stop + 1); 303 304 exit when 305 Is_Character (WC) 306 and then 307 not Is_Letter (To_Character (WC)) 308 and then 309 not Is_Letter (To_Character (WC)) 310 and then 311 (WC /= '_' or else From (Stop - 1) = '_'); 312 313 Stop := Stop + 1; 314 end loop; 315 end if; 316 317 end Scan_Enum_Lit; 318 319 ---------------- 320 -- Store_Char -- 321 ---------------- 322 323 procedure Store_Char 324 (WC : Wide_Wide_Character; 325 Buf : out Wide_Wide_String; 326 Ptr : in out Integer) 327 is 328 begin 329 if Ptr = Buf'Last then 330 raise Data_Error; 331 else 332 Ptr := Ptr + 1; 333 Buf (Ptr) := WC; 334 end if; 335 end Store_Char; 336 337 -------------- 338 -- To_Lower -- 339 -------------- 340 341 function To_Lower (C : Character) return Character is 342 begin 343 if C in 'A' .. 'Z' then 344 return Character'Val (Character'Pos (C) + 32); 345 else 346 return C; 347 end if; 348 end To_Lower; 349 350end Ada.Wide_Wide_Text_IO.Enumeration_Aux; 351