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