1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--      A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O     --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2021, 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
32with Ada.Wide_Wide_Text_IO.Decimal_Aux;
33with System.Img_Decimal_32;  use System.Img_Decimal_32;
34with System.Img_Decimal_64;  use System.Img_Decimal_64;
35with System.Val_Decimal_32;  use System.Val_Decimal_32;
36with System.Val_Decimal_64;  use System.Val_Decimal_64;
37with System.WCh_Con; use System.WCh_Con;
38with System.WCh_WtS; use System.WCh_WtS;
39
40package body Ada.Wide_Wide_Text_IO.Decimal_IO is
41
42   subtype Int32 is Interfaces.Integer_32;
43   subtype Int64 is Interfaces.Integer_64;
44
45   package Aux32 is new
46     Ada.Wide_Wide_Text_IO.Decimal_Aux
47       (Int32,
48        Scan_Decimal32,
49        Set_Image_Decimal32);
50
51   package Aux64 is new
52     Ada.Wide_Wide_Text_IO.Decimal_Aux
53       (Int64,
54        Scan_Decimal64,
55        Set_Image_Decimal64);
56
57   Need64 : constant Boolean := Num'Size > 32;
58   --  Throughout this generic body, we distinguish between the case where type
59   --  Int32 is acceptable and where type Int64 is needed. This Boolean is used
60   --  to test for these cases and since it is a constant, only code for the
61   --  relevant case will be included in the instance.
62
63   Scale : constant Integer := Num'Scale;
64
65   ---------
66   -- Get --
67   ---------
68
69   procedure Get
70     (File  : File_Type;
71      Item  : out Num;
72      Width : Field := 0)
73   is
74      pragma Unsuppress (Range_Check);
75
76   begin
77      if Need64 then
78         Item := Num'Fixed_Value (Aux64.Get (File, Width, Scale));
79      else
80         Item := Num'Fixed_Value (Aux32.Get (File, Width, Scale));
81      end if;
82
83   exception
84      when Constraint_Error => raise Data_Error;
85   end Get;
86
87   procedure Get
88     (Item  : out Num;
89      Width : Field := 0)
90   is
91   begin
92      Get (Current_In, Item, Width);
93   end Get;
94
95   procedure Get
96     (From : Wide_Wide_String;
97      Item : out Num;
98      Last : out Positive)
99   is
100      pragma Unsuppress (Range_Check);
101
102      S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper);
103      --  String on which we do the actual conversion. Note that the method
104      --  used for wide character encoding is irrelevant, since if there is
105      --  a character outside the Standard.Character range then the call to
106      --  Aux.Gets will raise Data_Error in any case.
107
108   begin
109      if Need64 then
110         Item := Num'Fixed_Value (Aux64.Gets (S, Last, Scale));
111      else
112         Item := Num'Fixed_Value (Aux32.Gets (S, Last, Scale));
113      end if;
114
115   exception
116      when Constraint_Error => raise Data_Error;
117   end Get;
118
119   ---------
120   -- Put --
121   ---------
122
123   procedure Put
124     (File : File_Type;
125      Item : Num;
126      Fore : Field := Default_Fore;
127      Aft  : Field := Default_Aft;
128      Exp  : Field := Default_Exp)
129   is
130   begin
131      if Need64 then
132         Aux64.Put
133           (File, Int64'Integer_Value (Item), Fore, Aft, Exp, Scale);
134      else
135         Aux32.Put
136           (File, Int32'Integer_Value (Item), Fore, Aft, Exp, Scale);
137      end if;
138   end Put;
139
140   procedure Put
141     (Item : Num;
142      Fore : Field := Default_Fore;
143      Aft  : Field := Default_Aft;
144      Exp  : Field := Default_Exp)
145   is
146   begin
147      Put (Current_Out, Item, Fore, Aft, Exp);
148   end Put;
149
150   procedure Put
151     (To   : out Wide_Wide_String;
152      Item : Num;
153      Aft  : Field := Default_Aft;
154      Exp  : Field := Default_Exp)
155   is
156      S : String (To'First .. To'Last);
157
158   begin
159      if Need64 then
160         Aux64.Puts (S, Int64'Integer_Value (Item), Aft, Exp, Scale);
161      else
162         Aux32.Puts (S, Int32'Integer_Value (Item), Aft, Exp, Scale);
163      end if;
164
165      for J in S'Range loop
166         To (J) := Wide_Wide_Character'Val (Character'Pos (S (J)));
167      end loop;
168   end Put;
169
170end Ada.Wide_Wide_Text_IO.Decimal_IO;
171