1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ 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_Text_IO.Integer_Aux; 33with System.Img_BIU; use System.Img_BIU; 34with System.Img_Int; use System.Img_Int; 35with System.Img_LLB; use System.Img_LLB; 36with System.Img_LLI; use System.Img_LLI; 37with System.Img_LLW; use System.Img_LLW; 38with System.Img_LLLB; use System.Img_LLLB; 39with System.Img_LLLI; use System.Img_LLLI; 40with System.Img_LLLW; use System.Img_LLLW; 41with System.Img_WIU; use System.Img_WIU; 42with System.Val_Int; use System.Val_Int; 43with System.Val_LLI; use System.Val_LLI; 44with System.Val_LLLI; use System.Val_LLLI; 45with System.WCh_Con; use System.WCh_Con; 46with System.WCh_WtS; use System.WCh_WtS; 47 48package body Ada.Wide_Text_IO.Integer_IO is 49 50 package Aux_Int is new 51 Ada.Wide_Text_IO.Integer_Aux 52 (Integer, 53 Scan_Integer, 54 Set_Image_Integer, 55 Set_Image_Width_Integer, 56 Set_Image_Based_Integer); 57 58 package Aux_LLI is new 59 Ada.Wide_Text_IO.Integer_Aux 60 (Long_Long_Integer, 61 Scan_Long_Long_Integer, 62 Set_Image_Long_Long_Integer, 63 Set_Image_Width_Long_Long_Integer, 64 Set_Image_Based_Long_Long_Integer); 65 66 package Aux_LLLI is new 67 Ada.Wide_Text_IO.Integer_Aux 68 (Long_Long_Long_Integer, 69 Scan_Long_Long_Long_Integer, 70 Set_Image_Long_Long_Long_Integer, 71 Set_Image_Width_Long_Long_Long_Integer, 72 Set_Image_Based_Long_Long_Long_Integer); 73 74 Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; 75 Need_LLLI : constant Boolean := Num'Base'Size > Long_Long_Integer'Size; 76 -- Throughout this generic body, we distinguish between cases where type 77 -- Integer is acceptable, where type Long_Long_Integer is acceptable and 78 -- where type Long_Long_Long_Integer is needed. These boolean constants 79 -- are used to test for these cases and since they are constant, only code 80 -- for the relevant case will be included in the instance. 81 82 --------- 83 -- Get -- 84 --------- 85 86 procedure Get 87 (File : File_Type; 88 Item : out Num; 89 Width : Field := 0) 90 is 91 -- We depend on a range check to get Data_Error 92 93 pragma Unsuppress (Range_Check); 94 pragma Unsuppress (Overflow_Check); 95 96 begin 97 if Need_LLLI then 98 Aux_LLLI.Get (File, Long_Long_Long_Integer (Item), Width); 99 elsif Need_LLI then 100 Aux_LLI.Get (File, Long_Long_Integer (Item), Width); 101 else 102 Aux_Int.Get (File, Integer (Item), Width); 103 end if; 104 105 exception 106 when Constraint_Error => raise Data_Error; 107 end Get; 108 109 procedure Get 110 (Item : out Num; 111 Width : Field := 0) 112 is 113 begin 114 Get (Current_In, Item, Width); 115 end Get; 116 117 procedure Get 118 (From : Wide_String; 119 Item : out Num; 120 Last : out Positive) 121 is 122 -- We depend on a range check to get Data_Error 123 124 pragma Unsuppress (Range_Check); 125 pragma Unsuppress (Overflow_Check); 126 127 S : constant String := Wide_String_To_String (From, WCEM_Upper); 128 -- String on which we do the actual conversion. Note that the method 129 -- used for wide character encoding is irrelevant, since if there is 130 -- a character outside the Standard.Character range then the call to 131 -- Aux.Gets will raise Data_Error in any case. 132 133 begin 134 if Need_LLLI then 135 Aux_LLLI.Gets (S, Long_Long_Long_Integer (Item), Last); 136 elsif Need_LLI then 137 Aux_LLI.Gets (S, Long_Long_Integer (Item), Last); 138 else 139 Aux_Int.Gets (S, Integer (Item), Last); 140 end if; 141 142 exception 143 when Constraint_Error => raise Data_Error; 144 end Get; 145 146 --------- 147 -- Put -- 148 --------- 149 150 procedure Put 151 (File : File_Type; 152 Item : Num; 153 Width : Field := Default_Width; 154 Base : Number_Base := Default_Base) 155 is 156 begin 157 if Need_LLLI then 158 Aux_LLLI.Put (File, Long_Long_Long_Integer (Item), Width, Base); 159 elsif Need_LLI then 160 Aux_LLI.Put (File, Long_Long_Integer (Item), Width, Base); 161 else 162 Aux_Int.Put (File, Integer (Item), Width, Base); 163 end if; 164 end Put; 165 166 procedure Put 167 (Item : Num; 168 Width : Field := Default_Width; 169 Base : Number_Base := Default_Base) 170 is 171 begin 172 Put (Current_Out, Item, Width, Base); 173 end Put; 174 175 procedure Put 176 (To : out Wide_String; 177 Item : Num; 178 Base : Number_Base := Default_Base) 179 is 180 S : String (To'First .. To'Last); 181 182 begin 183 if Need_LLLI then 184 Aux_LLLI.Puts (S, Long_Long_Long_Integer (Item), Base); 185 elsif Need_LLI then 186 Aux_LLI.Puts (S, Long_Long_Integer (Item), Base); 187 else 188 Aux_Int.Puts (S, Integer (Item), Base); 189 end if; 190 191 for J in S'Range loop 192 To (J) := Wide_Character'Val (Character'Pos (S (J))); 193 end loop; 194 end Put; 195 196end Ada.Wide_Text_IO.Integer_IO; 197