OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-tienau.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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-2011, 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
130
 
131
      if Line_Length /= 0 then
132
 
133
         --  If actual width exceeds line length, raise Layout_Error
134
 
135
         if Actual_Width > Line_Length 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 - 1) > Line_Length 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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.