1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
34 ------------------------------------------------------------------------------
36 with Ada
.Wide_Text_IO
.Generic_Aux
; use Ada
.Wide_Text_IO
.Generic_Aux
;
38 with System
.Img_BIU
; use System
.Img_BIU
;
39 with System
.Img_Uns
; use System
.Img_Uns
;
40 with System
.Img_LLB
; use System
.Img_LLB
;
41 with System
.Img_LLU
; use System
.Img_LLU
;
42 with System
.Img_LLW
; use System
.Img_LLW
;
43 with System
.Img_WIU
; use System
.Img_WIU
;
44 with System
.Val_Uns
; use System
.Val_Uns
;
45 with System
.Val_LLU
; use System
.Val_LLU
;
47 package body Ada
.Wide_Text_IO
.Modular_Aux
is
49 use System
.Unsigned_Types
;
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 procedure Load_Modular
58 Ptr
: in out Natural);
59 -- This is an auxiliary routine that is used to load an possibly signed
60 -- modular literal value from the input file into Buf, starting at Ptr + 1.
61 -- Ptr is left set to the last character stored.
69 Item
: out Long_Long_Unsigned
;
72 Buf
: String (1 .. Field
'Last);
74 Ptr
: aliased Integer := 1;
78 Load_Width
(File
, Width
, Buf
, Stop
);
79 String_Skip
(Buf
, Ptr
);
81 Load_Modular
(File
, Buf
, Stop
);
84 Item
:= Scan_Long_Long_Unsigned
(Buf
, Ptr
'Access, Stop
);
85 Check_End_Of_Field
(File
, Buf
, Stop
, Ptr
, Width
);
97 Buf
: String (1 .. Field
'Last);
99 Ptr
: aliased Integer := 1;
103 Load_Width
(File
, Width
, Buf
, Stop
);
104 String_Skip
(Buf
, Ptr
);
106 Load_Modular
(File
, Buf
, Stop
);
109 Item
:= Scan_Unsigned
(Buf
, Ptr
'Access, Stop
);
110 Check_End_Of_Field
(File
, Buf
, Stop
, Ptr
, Width
);
119 Item
: out Long_Long_Unsigned
;
122 Pos
: aliased Integer;
125 String_Skip
(From
, Pos
);
126 Item
:= Scan_Long_Long_Unsigned
(From
, Pos
'Access, From
'Last);
130 when Constraint_Error
=>
145 Pos
: aliased Integer;
148 String_Skip
(From
, Pos
);
149 Item
:= Scan_Unsigned
(From
, Pos
'Access, From
'Last);
153 when Constraint_Error
=>
163 procedure Load_Modular
164 (File
: in File_Type
;
166 Ptr
: in out Natural)
174 -- Note: it is a bit strange to allow a minus sign here, but it seems
175 -- consistent with the general behavior expected by the ACVC tests
176 -- which is to scan past junk and then signal data error, see ACVC
177 -- test CE3704F, case (6), which is for signed integer exponents,
178 -- which seems a similar case.
180 Load
(File
, Buf
, Ptr
, '+', '-');
181 Load_Digits
(File
, Buf
, Ptr
, Loaded
);
184 Load
(File
, Buf
, Ptr
, '#', ':', Loaded
);
188 Load_Extended_Digits
(File
, Buf
, Ptr
);
189 Load
(File
, Buf
, Ptr
, Buf
(Hash_Loc
));
192 Load
(File
, Buf
, Ptr
, 'E', 'e', Loaded
);
196 -- Note: it is strange to allow a minus sign, since the syntax
197 -- does not, but that is what ACVC test CE3704F, case (6) wants
198 -- for the signed case, and there seems no good reason to treat
199 -- exponents differently for the signed and unsigned cases.
201 Load
(File
, Buf
, Ptr
, '+', '-');
202 Load_Digits
(File
, Buf
, Ptr
);
212 (File
: in File_Type
;
213 Item
: in Long_Long_Unsigned
;
215 Base
: in Number_Base
)
217 Buf
: String (1 .. Field
'Last);
221 if Base
= 10 and then Width
= 0 then
222 Set_Image_Long_Long_Unsigned
(Item
, Buf
, Ptr
);
224 Set_Image_Width_Long_Long_Unsigned
(Item
, Width
, Buf
, Ptr
);
226 Set_Image_Based_Long_Long_Unsigned
(Item
, Base
, Width
, Buf
, Ptr
);
229 Put_Item
(File
, Buf
(1 .. Ptr
));
237 (File
: in File_Type
;
240 Base
: in Number_Base
)
242 Buf
: String (1 .. Field
'Last);
246 if Base
= 10 and then Width
= 0 then
247 Set_Image_Unsigned
(Item
, Buf
, Ptr
);
249 Set_Image_Width_Unsigned
(Item
, Width
, Buf
, Ptr
);
251 Set_Image_Based_Unsigned
(Item
, Base
, Width
, Buf
, Ptr
);
254 Put_Item
(File
, Buf
(1 .. Ptr
));
263 Item
: in Long_Long_Unsigned
;
264 Base
: in Number_Base
)
266 Buf
: String (1 .. Field
'Last);
271 Set_Image_Width_Long_Long_Unsigned
(Item
, To
'Length, Buf
, Ptr
);
273 Set_Image_Based_Long_Long_Unsigned
(Item
, Base
, To
'Length, Buf
, Ptr
);
276 if Ptr
> To
'Length then
279 To
(To
'First .. To
'First + Ptr
- 1) := Buf
(1 .. Ptr
);
290 Base
: in Number_Base
)
292 Buf
: String (1 .. Field
'Last);
297 Set_Image_Width_Unsigned
(Item
, To
'Length, Buf
, Ptr
);
299 Set_Image_Based_Unsigned
(Item
, Base
, To
'Length, Buf
, Ptr
);
302 if Ptr
> To
'Length then
305 To
(To
'First .. To
'First + Ptr
- 1) := Buf
(1 .. Ptr
);
309 end Ada
.Wide_Text_IO
.Modular_Aux
;