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-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_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