OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [ada/] [a-tienau.adb] - Blame information for rev 516

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 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-2009, 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 
      if Set = Lower_Case and then Item (Item'First) /= ''' then
130 
         declare
131 
            Iteml : String (Item'First .. Item'Last);
132 
 
133 
         begin
134 
            for J in Item'Range loop
135 
               Iteml (J) := To_Lower (Item (J));
136 
            end loop;
137 
 
138 
            Put_Item (File, Iteml);
139 
         end;
140 
 
141 
      else
142 
         Put_Item (File, Item);
143 
      end if;
144 
 
145 
      for J in 1 .. Actual_Width - Item'Length loop
146 
         Put (File, ' ');
147 
      end loop;
148 
   end Put;
149 
 
150 
   ----------
151 
   -- Puts --
152 
   ----------
153 
 
154 
   procedure Puts
155 
     (To   : out String;
156 
      Item : String;
157 
      Set  : Type_Set)
158 
   is
159 
      Ptr : Natural;
160 
 
161 
   begin
162 
      if Item'Length > To'Length then
163 
         raise Layout_Error;
164 
 
165 
      else
166 
         Ptr := To'First;
167 
         for J in Item'Range loop
168 
            if Set = Lower_Case and then Item (Item'First) /= ''' then
169 
               To (Ptr) := To_Lower (Item (J));
170 
            else
171 
               To (Ptr) := Item (J);
172 
            end if;
173 
 
174 
            Ptr := Ptr + 1;
175 
         end loop;
176 
 
177 
         while Ptr <= To'Last loop
178 
            To (Ptr) := ' ';
179 
            Ptr := Ptr + 1;
180 
         end loop;
181 
      end if;
182 
   end Puts;
183 
 
184 
   -------------------
185 
   -- Scan_Enum_Lit --
186 
   -------------------
187 
 
188 
   procedure Scan_Enum_Lit
189 
     (From  : String;
190 
      Start : out Natural;
191 
      Stop  : out Natural)
192 
   is
193 
      C  : Character;
194 
 
195 
   --  Processing for Scan_Enum_Lit
196 
 
197 
   begin
198 
      String_Skip (From, Start);
199 
 
200 
      --  Character literal case. If the initial character is a quote, then
201 
      --  we read as far as we can without backup (see ACVC test CE3905L
202 
      --  which is for the analogous case for reading from a file).
203 
 
204 
      if From (Start) = ''' then
205 
         Stop := Start;
206 
 
207 
         if Stop = From'Last then
208 
            raise Data_Error;
209 
         else
210 
            Stop := Stop + 1;
211 
         end if;
212 
 
213 
         if From (Stop) in ' ' .. '~'
214 
           or else From (Stop) >= Character'Val (16#80#)
215 
         then
216 
            if Stop = From'Last then
217 
               raise Data_Error;
218 
            else
219 
               Stop := Stop + 1;
220 
 
221 
               if From (Stop) = ''' then
222 
                  return;
223 
               end if;
224 
            end if;
225 
         end if;
226 
 
227 
         raise Data_Error;
228 
 
229 
      --  Similarly for identifiers, read as far as we can, in particular,
230 
      --  do read a trailing underscore (again see ACVC test CE3905L to
231 
      --  understand why we do this, although it seems somewhat peculiar).
232 
 
233 
      else
234 
         --  Identifier must start with a letter
235 
 
236 
         if not Is_Letter (From (Start)) then
237 
            raise Data_Error;
238 
         end if;
239 
 
240 
         --  If we do have a letter, loop through the characters quitting on
241 
         --  the first non-identifier character (note that this includes the
242 
         --  cases of hitting a line mark or page mark).
243 
 
244 
         Stop := Start;
245 
         while Stop < From'Last loop
246 
            C := From (Stop + 1);
247 
 
248 
            exit when not Is_Letter (C)
249 
              and then not Is_Digit (C)
250 
              and then C /= '_';
251 
 
252 
            exit when C = '_'
253 
              and then From (Stop) = '_';
254 
 
255 
            Stop := Stop + 1;
256 
         end loop;
257 
      end if;
258 
   end Scan_Enum_Lit;
259 
 
260 
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.