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