1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--          A D A . 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-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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
33with Ada.Characters.Handling; use Ada.Characters.Handling;
34
35--  Note: this package does not yet deal properly with wide characters ???
36
37package body Ada.Text_IO.Enumeration_Aux is
38
39   ------------------
40   -- Get_Enum_Lit --
41   ------------------
42
43   procedure Get_Enum_Lit
44     (File   : File_Type;
45      Buf    : out String;
46      Buflen : out Natural)
47   is
48      ch  : Integer;
49      C   : Character;
50
51   begin
52      Buflen := 0;
53      Load_Skip (File);
54      ch := Getc (File);
55      C := Character'Val (ch);
56
57      --  Character literal case. If the initial character is a quote, then
58      --  we read as far as we can without backup (see ACVC test CE3905L)
59
60      if C = ''' then
61         Store_Char (File, ch, Buf, Buflen);
62
63         ch := Getc (File);
64
65         if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
66            Store_Char (File, ch, Buf, Buflen);
67
68            ch := Getc (File);
69
70            if ch = Character'Pos (''') then
71               Store_Char (File, ch, Buf, Buflen);
72            else
73               Ungetc (ch, File);
74            end if;
75
76         else
77            Ungetc (ch, File);
78         end if;
79
80      --  Similarly for identifiers, read as far as we can, in particular,
81      --  do read a trailing underscore (again see ACVC test CE3905L to
82      --  understand why we do this, although it seems somewhat peculiar).
83
84      else
85         --  Identifier must start with a letter
86
87         if not Is_Letter (C) then
88            Ungetc (ch, File);
89            return;
90         end if;
91
92         --  If we do have a letter, loop through the characters quitting on
93         --  the first non-identifier character (note that this includes the
94         --  cases of hitting a line mark or page mark).
95
96         loop
97            C := Character'Val (ch);
98            Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
99
100            ch := Getc (File);
101            exit when ch = EOF_Char;
102            C := Character'Val (ch);
103
104            exit when not Is_Letter (C)
105              and then not Is_Digit (C)
106              and then C /= '_';
107
108            exit when C = '_'
109              and then Buf (Buflen) = '_';
110         end loop;
111
112         Ungetc (ch, File);
113      end if;
114   end Get_Enum_Lit;
115
116   ---------
117   -- Put --
118   ---------
119
120   procedure Put
121     (File  : File_Type;
122      Item  : String;
123      Width : Field;
124      Set   : Type_Set)
125   is
126      Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
127
128   begin
129      --  Deal with limited line length of output file
130
131      if Line_Length (File) /= 0 then
132
133         --  If actual width exceeds line length, raise Layout_Error
134
135         if Actual_Width > Line_Length (File) then
136            raise Layout_Error;
137         end if;
138
139         --  If full width cannot fit on current line move to new line
140
141         if Actual_Width + (Col (File) - 1) > Line_Length (File) then
142            New_Line (File);
143         end if;
144      end if;
145
146      --  Output in lower case if necessary
147
148      if Set = Lower_Case and then Item (Item'First) /= ''' then
149         declare
150            Iteml : String (Item'First .. Item'Last);
151
152         begin
153            for J in Item'Range loop
154               Iteml (J) := To_Lower (Item (J));
155            end loop;
156
157            Put_Item (File, Iteml);
158         end;
159
160      --  Otherwise output in upper case
161
162      else
163         Put_Item (File, Item);
164      end if;
165
166      --  Fill out item with spaces to width
167
168      for J in 1 .. Actual_Width - Item'Length loop
169         Put (File, ' ');
170      end loop;
171   end Put;
172
173   ----------
174   -- Puts --
175   ----------
176
177   procedure Puts
178     (To   : out String;
179      Item : String;
180      Set  : Type_Set)
181   is
182      Ptr : Natural;
183
184   begin
185      if Item'Length > To'Length then
186         raise Layout_Error;
187
188      else
189         Ptr := To'First;
190         for J in Item'Range loop
191            if Set = Lower_Case and then Item (Item'First) /= ''' then
192               To (Ptr) := To_Lower (Item (J));
193            else
194               To (Ptr) := Item (J);
195            end if;
196
197            Ptr := Ptr + 1;
198         end loop;
199
200         while Ptr <= To'Last loop
201            To (Ptr) := ' ';
202            Ptr := Ptr + 1;
203         end loop;
204      end if;
205   end Puts;
206
207   -------------------
208   -- Scan_Enum_Lit --
209   -------------------
210
211   procedure Scan_Enum_Lit
212     (From  : String;
213      Start : out Natural;
214      Stop  : out Natural)
215   is
216      C  : Character;
217
218   --  Processing for Scan_Enum_Lit
219
220   begin
221      String_Skip (From, Start);
222
223      --  Character literal case. If the initial character is a quote, then
224      --  we read as far as we can without backup (see ACVC test CE3905L
225      --  which is for the analogous case for reading from a file).
226
227      if From (Start) = ''' then
228         Stop := Start;
229
230         if Stop = From'Last then
231            raise Data_Error;
232         else
233            Stop := Stop + 1;
234         end if;
235
236         if From (Stop) in ' ' .. '~'
237           or else From (Stop) >= Character'Val (16#80#)
238         then
239            if Stop = From'Last then
240               raise Data_Error;
241            else
242               Stop := Stop + 1;
243
244               if From (Stop) = ''' then
245                  return;
246               end if;
247            end if;
248         end if;
249
250         raise Data_Error;
251
252      --  Similarly for identifiers, read as far as we can, in particular,
253      --  do read a trailing underscore (again see ACVC test CE3905L to
254      --  understand why we do this, although it seems somewhat peculiar).
255
256      else
257         --  Identifier must start with a letter
258
259         if not Is_Letter (From (Start)) then
260            raise Data_Error;
261         end if;
262
263         --  If we do have a letter, loop through the characters quitting on
264         --  the first non-identifier character (note that this includes the
265         --  cases of hitting a line mark or page mark).
266
267         Stop := Start;
268         while Stop < From'Last loop
269            C := From (Stop + 1);
270
271            exit when not Is_Letter (C)
272              and then not Is_Digit (C)
273              and then C /= '_';
274
275            exit when C = '_'
276              and then From (Stop) = '_';
277
278            Stop := Stop + 1;
279         end loop;
280      end if;
281   end Scan_Enum_Lit;
282
283end Ada.Text_IO.Enumeration_Aux;
284