Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/a-tienau.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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
32 with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
33 with Ada.Characters.Handling; use Ada.Characters.Handling;
34
35 -- Note: this package does not yet deal properly with wide characters ???
36
37 package 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
283 end Ada.Text_IO.Enumeration_Aux;