1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . 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.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_WIU; use System.Img_WIU; 39with System.Val_Uns; use System.Val_Uns; 40with System.Val_LLU; use System.Val_LLU; 41 42package body Ada.Text_IO.Modular_IO is 43 44 package Aux_Uns is new 45 Ada.Text_IO.Integer_Aux 46 (Unsigned, 47 Scan_Unsigned, 48 Set_Image_Unsigned, 49 Set_Image_Width_Unsigned, 50 Set_Image_Based_Unsigned); 51 52 package Aux_LLU is new 53 Ada.Text_IO.Integer_Aux 54 (Long_Long_Unsigned, 55 Scan_Long_Long_Unsigned, 56 Set_Image_Long_Long_Unsigned, 57 Set_Image_Width_Long_Long_Unsigned, 58 Set_Image_Based_Long_Long_Unsigned); 59 60 Need_LLU : constant Boolean := Num'Base'Size > Unsigned'Size; 61 -- Throughout this generic body, we distinguish between the case where type 62 -- Unsigned is acceptable, and where a Long_Long_Unsigned is needed. This 63 -- Boolean is used to test for these cases and since it is a constant, only 64 -- code for the relevant case will be included in the instance. 65 66 --------- 67 -- Get -- 68 --------- 69 70 procedure Get 71 (File : File_Type; 72 Item : out Num; 73 Width : Field := 0) 74 is 75 -- We depend on a range check to get Data_Error 76 77 pragma Unsuppress (Range_Check); 78 79 begin 80 if Need_LLU then 81 Aux_LLU.Get (File, Long_Long_Unsigned (Item), Width); 82 else 83 Aux_Uns.Get (File, Unsigned (Item), Width); 84 end if; 85 86 exception 87 when Constraint_Error => raise Data_Error; 88 end Get; 89 90 procedure Get 91 (Item : out Num; 92 Width : Field := 0) 93 is 94 begin 95 Get (Current_In, Item, Width); 96 end Get; 97 98 procedure Get 99 (From : String; 100 Item : out Num; 101 Last : out Positive) 102 is 103 -- We depend on a range check to get Data_Error 104 105 pragma Unsuppress (Range_Check); 106 107 begin 108 if Need_LLU then 109 Aux_LLU.Gets (From, Long_Long_Unsigned (Item), Last); 110 else 111 Aux_Uns.Gets (From, Unsigned (Item), Last); 112 end if; 113 114 exception 115 when Constraint_Error => raise Data_Error; 116 end Get; 117 118 --------- 119 -- Put -- 120 --------- 121 122 procedure Put 123 (File : File_Type; 124 Item : Num; 125 Width : Field := Default_Width; 126 Base : Number_Base := Default_Base) 127 is 128 begin 129 if Need_LLU then 130 Aux_LLU.Put (File, Long_Long_Unsigned (Item), Width, Base); 131 else 132 Aux_Uns.Put (File, Unsigned (Item), Width, Base); 133 end if; 134 end Put; 135 136 procedure Put 137 (Item : Num; 138 Width : Field := Default_Width; 139 Base : Number_Base := Default_Base) 140 is 141 begin 142 Put (Current_Out, Item, Width, Base); 143 end Put; 144 145 procedure Put 146 (To : out String; 147 Item : Num; 148 Base : Number_Base := Default_Base) 149 is 150 begin 151 if Need_LLU then 152 Aux_LLU.Puts (To, Long_Long_Unsigned (Item), Base); 153 else 154 Aux_Uns.Puts (To, Unsigned (Item), Base); 155 end if; 156 end Put; 157 158end Ada.Text_IO.Modular_IO; 159