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 --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 with Ada
.Wide_Text_IO
.Generic_Aux
; use Ada
.Wide_Text_IO
.Generic_Aux
;
37 with System
.Img_BIU
; use System
.Img_BIU
;
38 with System
.Img_Uns
; use System
.Img_Uns
;
39 with System
.Img_LLB
; use System
.Img_LLB
;
40 with System
.Img_LLU
; use System
.Img_LLU
;
41 with System
.Img_LLW
; use System
.Img_LLW
;
42 with System
.Img_WIU
; use System
.Img_WIU
;
43 with System
.Val_Uns
; use System
.Val_Uns
;
44 with System
.Val_LLU
; use System
.Val_LLU
;
46 package body Ada
.Wide_Text_IO
.Modular_Aux
is
48 use System
.Unsigned_Types
;
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 procedure Load_Modular
57 Ptr
: in out Natural);
58 -- This is an auxiliary routine that is used to load an possibly signed
59 -- modular literal value from the input file into Buf, starting at Ptr + 1.
60 -- Ptr is left set to the last character stored.
68 Item
: out Long_Long_Unsigned
;
71 Buf
: String (1 .. Field
'Last);
73 Ptr
: aliased Integer := 1;
77 Load_Width
(File
, Width
, Buf
, Stop
);
78 String_Skip
(Buf
, Ptr
);
80 Load_Modular
(File
, Buf
, Stop
);
83 Item
:= Scan_Long_Long_Unsigned
(Buf
, Ptr
'Access, Stop
);
84 Check_End_Of_Field
(Buf
, Stop
, Ptr
, Width
);
96 Buf
: String (1 .. Field
'Last);
98 Ptr
: aliased Integer := 1;
102 Load_Width
(File
, Width
, Buf
, Stop
);
103 String_Skip
(Buf
, Ptr
);
105 Load_Modular
(File
, Buf
, Stop
);
108 Item
:= Scan_Unsigned
(Buf
, Ptr
'Access, Stop
);
109 Check_End_Of_Field
(Buf
, Stop
, Ptr
, Width
);
118 Item
: out Long_Long_Unsigned
;
121 Pos
: aliased Integer;
124 String_Skip
(From
, Pos
);
125 Item
:= Scan_Long_Long_Unsigned
(From
, Pos
'Access, From
'Last);
129 when Constraint_Error
=>
144 Pos
: aliased Integer;
147 String_Skip
(From
, Pos
);
148 Item
:= Scan_Unsigned
(From
, Pos
'Access, From
'Last);
152 when Constraint_Error
=>
162 procedure Load_Modular
163 (File
: in File_Type
;
165 Ptr
: in out Natural)
173 -- Note: it is a bit strange to allow a minus sign here, but it seems
174 -- consistent with the general behavior expected by the ACVC tests
175 -- which is to scan past junk and then signal data error, see ACVC
176 -- test CE3704F, case (6), which is for signed integer exponents,
177 -- which seems a similar case.
179 Load
(File
, Buf
, Ptr
, '+', '-');
180 Load_Digits
(File
, Buf
, Ptr
, Loaded
);
183 Load
(File
, Buf
, Ptr
, '#', ':', Loaded
);
187 Load_Extended_Digits
(File
, Buf
, Ptr
);
188 Load
(File
, Buf
, Ptr
, Buf
(Hash_Loc
));
191 Load
(File
, Buf
, Ptr
, 'E', 'e', Loaded
);
195 -- Note: it is strange to allow a minus sign, since the syntax
196 -- does not, but that is what ACVC test CE3704F, case (6) wants
197 -- for the signed case, and there seems no good reason to treat
198 -- exponents differently for the signed and unsigned cases.
200 Load
(File
, Buf
, Ptr
, '+', '-');
201 Load_Digits
(File
, Buf
, Ptr
);
211 (File
: in File_Type
;
212 Item
: in Long_Long_Unsigned
;
214 Base
: in Number_Base
)
216 Buf
: String (1 .. Field
'Last);
220 if Base
= 10 and then Width
= 0 then
221 Set_Image_Long_Long_Unsigned
(Item
, Buf
, Ptr
);
223 Set_Image_Width_Long_Long_Unsigned
(Item
, Width
, Buf
, Ptr
);
225 Set_Image_Based_Long_Long_Unsigned
(Item
, Base
, Width
, Buf
, Ptr
);
228 Put_Item
(File
, Buf
(1 .. Ptr
));
236 (File
: in File_Type
;
239 Base
: in Number_Base
)
241 Buf
: String (1 .. Field
'Last);
245 if Base
= 10 and then Width
= 0 then
246 Set_Image_Unsigned
(Item
, Buf
, Ptr
);
248 Set_Image_Width_Unsigned
(Item
, Width
, Buf
, Ptr
);
250 Set_Image_Based_Unsigned
(Item
, Base
, Width
, Buf
, Ptr
);
253 Put_Item
(File
, Buf
(1 .. Ptr
));
262 Item
: in Long_Long_Unsigned
;
263 Base
: in Number_Base
)
265 Buf
: String (1 .. Field
'Last);
270 Set_Image_Width_Long_Long_Unsigned
(Item
, To
'Length, Buf
, Ptr
);
272 Set_Image_Based_Long_Long_Unsigned
(Item
, Base
, To
'Length, Buf
, Ptr
);
275 if Ptr
> To
'Length then
278 To
(To
'First .. To
'First + Ptr
- 1) := Buf
(1 .. Ptr
);
289 Base
: in Number_Base
)
291 Buf
: String (1 .. Field
'Last);
296 Set_Image_Width_Unsigned
(Item
, To
'Length, Buf
, Ptr
);
298 Set_Image_Based_Unsigned
(Item
, Base
, To
'Length, Buf
, Ptr
);
301 if Ptr
> To
'Length then
304 To
(To
'First .. To
'First + Ptr
- 1) := Buf
(1 .. Ptr
);
308 end Ada
.Wide_Text_IO
.Modular_Aux
;