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