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