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 . M O D U L A R _ I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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.Integer_Aux; 33with System.Img_BIU; use System.Img_BIU; 34with System.Img_Uns; use System.Img_Uns; 35with System.Img_LLB; use System.Img_LLB; 36with System.Img_LLU; use System.Img_LLU; 37with System.Img_LLW; use System.Img_LLW; 38with System.Img_LLLB; use System.Img_LLLB; 39with System.Img_LLLU; use System.Img_LLLU; 40with System.Img_LLLW; use System.Img_LLLW; 41with System.Img_WIU; use System.Img_WIU; 42with System.Val_Uns; use System.Val_Uns; 43with System.Val_LLU; use System.Val_LLU; 44with System.Val_LLLU; use System.Val_LLLU; 45with System.WCh_Con; use System.WCh_Con; 46with System.WCh_WtS; use System.WCh_WtS; 47 48package body Ada.Wide_Wide_Text_IO.Modular_IO is 49 50 package Aux_Uns is new 51 Ada.Wide_Wide_Text_IO.Integer_Aux 52 (Unsigned, 53 Scan_Unsigned, 54 Set_Image_Unsigned, 55 Set_Image_Width_Unsigned, 56 Set_Image_Based_Unsigned); 57 58 package Aux_LLU is new 59 Ada.Wide_Wide_Text_IO.Integer_Aux 60 (Long_Long_Unsigned, 61 Scan_Long_Long_Unsigned, 62 Set_Image_Long_Long_Unsigned, 63 Set_Image_Width_Long_Long_Unsigned, 64 Set_Image_Based_Long_Long_Unsigned); 65 66 package Aux_LLLU is new 67 Ada.Wide_Wide_Text_IO.Integer_Aux 68 (Long_Long_Long_Unsigned, 69 Scan_Long_Long_Long_Unsigned, 70 Set_Image_Long_Long_Long_Unsigned, 71 Set_Image_Width_Long_Long_Long_Unsigned, 72 Set_Image_Based_Long_Long_Long_Unsigned); 73 74 Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; 75 Need_LLLU : constant Boolean := Num'Base'Size > Long_Long_Unsigned'Size; 76 -- Throughout this generic body, we distinguish between cases where type 77 -- Unsigned is acceptable, where type Long_Long_Unsigned is acceptable and 78 -- where type Long_Long_Long_Unsigned 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 95 begin 96 if Need_LLLU then 97 Aux_LLLU.Get (File, Long_Long_Long_Unsigned (Item), Width); 98 elsif Need_LLU then 99 Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width); 100 else 101 Aux_Uns.Get (File, Unsigned (Item), Width); 102 end if; 103 104 exception 105 when Constraint_Error => raise Data_Error; 106 end Get; 107 108 procedure Get 109 (Item : out Num; 110 Width : Field := 0) 111 is 112 begin 113 Get (Current_In, Item, Width); 114 end Get; 115 116 procedure Get 117 (From : Wide_Wide_String; 118 Item : out Num; 119 Last : out Positive) 120 is 121 -- We depend on a range check to get Data_Error 122 123 pragma Unsuppress (Range_Check); 124 125 S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); 126 -- String on which we do the actual conversion. Note that the method 127 -- used for wide character encoding is irrelevant, since if there is 128 -- a character outside the Standard.Character range then the call to 129 -- Aux.Gets will raise Data_Error in any case. 130 131 begin 132 if Need_LLLU then 133 Aux_LLLU.Gets (S, Long_Long_Long_Unsigned (Item), Last); 134 elsif Need_LLU then 135 Aux_LLU.Gets (S, Long_Long_Unsigned (Item), Last); 136 else 137 Aux_Uns.Gets (S, Unsigned (Item), Last); 138 end if; 139 140 exception 141 when Constraint_Error => raise Data_Error; 142 end Get; 143 144 --------- 145 -- Put -- 146 --------- 147 148 procedure Put 149 (File : File_Type; 150 Item : Num; 151 Width : Field := Default_Width; 152 Base : Number_Base := Default_Base) 153 is 154 begin 155 if Need_LLLU then 156 Aux_LLLU.Put (File, Long_Long_Long_Unsigned (Item), Width, Base); 157 elsif Need_LLU then 158 Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base); 159 else 160 Aux_Uns.Put (File, Unsigned (Item), Width, Base); 161 end if; 162 end Put; 163 164 procedure Put 165 (Item : Num; 166 Width : Field := Default_Width; 167 Base : Number_Base := Default_Base) 168 is 169 begin 170 Put (Current_Out, Item, Width, Base); 171 end Put; 172 173 procedure Put 174 (To : out Wide_Wide_String; 175 Item : Num; 176 Base : Number_Base := Default_Base) 177 is 178 S : String (To'First .. To'Last); 179 180 begin 181 if Need_LLLU then 182 Aux_LLLU.Puts (S, Long_Long_Long_Unsigned (Item), Base); 183 elsif Need_LLU then 184 Aux_LLU.Puts (S, Long_Long_Unsigned (Item), Base); 185 else 186 Aux_Uns.Puts (S, Unsigned (Item), Base); 187 end if; 188 189 for J in S'Range loop 190 To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); 191 end loop; 192 end Put; 193 194end Ada.Wide_Wide_Text_IO.Modular_IO; 195