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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [a-wtflau.adb] - Blame information for rev 281

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 . W I D E _ T E X T _ I O . F L O A T _ 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.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
33
 
34
with System.Img_Real;  use System.Img_Real;
35
with System.Val_Real;  use System.Val_Real;
36
 
37
package body Ada.Wide_Text_IO.Float_Aux is
38
 
39
   ---------
40
   -- Get --
41
   ---------
42
 
43
   procedure Get
44
     (File  : File_Type;
45
      Item  : out Long_Long_Float;
46
      Width : Field)
47
   is
48
      Buf  : String (1 .. Field'Last);
49
      Stop : Integer := 0;
50
      Ptr  : aliased Integer := 1;
51
 
52
   begin
53
      if Width /= 0 then
54
         Load_Width (File, Width, Buf, Stop);
55
         String_Skip (Buf, Ptr);
56
      else
57
         Load_Real (File, Buf, Stop);
58
      end if;
59
 
60
      Item := Scan_Real (Buf, Ptr'Access, Stop);
61
 
62
      Check_End_Of_Field (Buf, Stop, Ptr, Width);
63
   end Get;
64
 
65
   ----------
66
   -- Gets --
67
   ----------
68
 
69
   procedure Gets
70
     (From : String;
71
      Item : out Long_Long_Float;
72
      Last : out Positive)
73
   is
74
      Pos : aliased Integer;
75
 
76
   begin
77
      String_Skip (From, Pos);
78
      Item := Scan_Real (From, Pos'Access, From'Last);
79
      Last := Pos - 1;
80
 
81
   exception
82
      when Constraint_Error =>
83
         raise Data_Error;
84
   end Gets;
85
 
86
   ---------------
87
   -- Load_Real --
88
   ---------------
89
 
90
   procedure Load_Real
91
     (File : File_Type;
92
      Buf  : out String;
93
      Ptr  : in out Natural)
94
   is
95
      Loaded   : Boolean;
96
 
97
   begin
98
      --  Skip initial blanks and load possible sign
99
 
100
      Load_Skip (File);
101
      Load (File, Buf, Ptr, '+', '-');
102
 
103
      --  Case of .nnnn
104
 
105
      Load (File, Buf, Ptr, '.', Loaded);
106
 
107
      if Loaded then
108
         Load_Digits (File, Buf, Ptr, Loaded);
109
 
110
         --  Hopeless junk if no digits loaded
111
 
112
         if not Loaded then
113
            return;
114
         end if;
115
 
116
      --  Otherwise must have digits to start
117
 
118
      else
119
         Load_Digits (File, Buf, Ptr, Loaded);
120
 
121
         --  Hopeless junk if no digits loaded
122
 
123
         if not Loaded then
124
            return;
125
         end if;
126
 
127
         --  Based cases
128
 
129
         Load (File, Buf, Ptr, '#', ':', Loaded);
130
 
131
         if Loaded then
132
 
133
            --  Case of nnn#.xxx#
134
 
135
            Load (File, Buf, Ptr, '.', Loaded);
136
 
137
            if Loaded then
138
               Load_Extended_Digits (File, Buf, Ptr);
139
               Load (File, Buf, Ptr, '#', ':');
140
 
141
            --  Case of nnn#xxx.[xxx]# or nnn#xxx#
142
 
143
            else
144
               Load_Extended_Digits (File, Buf, Ptr);
145
               Load (File, Buf, Ptr, '.', Loaded);
146
 
147
               if Loaded then
148
                  Load_Extended_Digits (File, Buf, Ptr);
149
               end if;
150
 
151
               --  As usual, it seems strange to allow mixed base characters,
152
               --  but that is what ACVC tests expect, see CE3804M, case (3).
153
 
154
               Load (File, Buf, Ptr, '#', ':');
155
            end if;
156
 
157
         --  Case of nnn.[nnn] or nnn
158
 
159
         else
160
            --  Prevent the potential processing of '.' in cases where the
161
            --  initial digits have a trailing underscore.
162
 
163
            if Buf (Ptr) = '_' then
164
               return;
165
            end if;
166
 
167
            Load (File, Buf, Ptr, '.', Loaded);
168
 
169
            if Loaded then
170
               Load_Digits (File, Buf, Ptr);
171
            end if;
172
         end if;
173
      end if;
174
 
175
      --  Deal with exponent
176
 
177
      Load (File, Buf, Ptr, 'E', 'e', Loaded);
178
 
179
      if Loaded then
180
         Load (File, Buf, Ptr, '+', '-');
181
         Load_Digits (File, Buf, Ptr);
182
      end if;
183
   end Load_Real;
184
 
185
   ---------
186
   -- Put --
187
   ---------
188
 
189
   procedure Put
190
     (File : File_Type;
191
      Item : Long_Long_Float;
192
      Fore : Field;
193
      Aft  : Field;
194
      Exp  : Field)
195
   is
196
      Buf : String (1 .. Field'Last);
197
      Ptr : Natural := 0;
198
 
199
   begin
200
      Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp);
201
      Put_Item (File, Buf (1 .. Ptr));
202
   end Put;
203
 
204
   ----------
205
   -- Puts --
206
   ----------
207
 
208
   procedure Puts
209
     (To   : out String;
210
      Item : Long_Long_Float;
211
      Aft  : Field;
212
      Exp  : Field)
213
   is
214
      Buf : String (1 .. Field'Last);
215
      Ptr : Natural := 0;
216
 
217
   begin
218
      Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp);
219
 
220
      if Ptr > To'Length then
221
         raise Layout_Error;
222
 
223
      else
224
         for J in 1 .. Ptr loop
225
            To (To'Last - Ptr + J) := Buf (J);
226
         end loop;
227
 
228
         for J in To'First .. To'Last - Ptr loop
229
            To (J) := ' ';
230
         end loop;
231
      end if;
232
   end Puts;
233
 
234
end Ada.Wide_Text_IO.Float_Aux;

powered by: WebSVN 2.1.0

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