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