gcc/ada/libgnat/a-wtcoio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --           A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, 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
  32 with Ada.Wide_Text_IO.Complex_Aux;
  33 with Ada.Wide_Text_IO.Float_Aux;
  34 with System.Img_Flt;  use System.Img_Flt;
  35 with System.Img_LFlt; use System.Img_LFlt;
  36 with System.Img_LLF;  use System.Img_LLF;
  37 with System.Val_Flt;  use System.Val_Flt;
  38 with System.Val_LFlt; use System.Val_LFlt;
  39 with System.Val_LLF;  use System.Val_LLF;
  40 with System.WCh_Con;  use System.WCh_Con;
  41 with System.WCh_WtS;  use System.WCh_WtS;
  42
  43 package body Ada.Wide_Text_IO.Complex_IO is
  44
  45    use Complex_Types;
  46
  47    package Scalar_Float is new
  48      Ada.Wide_Text_IO.Float_Aux (Float, Scan_Float, Set_Image_Float);
  49
  50    package Scalar_Long_Float is new
  51      Ada.Wide_Text_IO.Float_Aux
  52        (Long_Float, Scan_Long_Float, Set_Image_Long_Float);
  53
  54    package Scalar_Long_Long_Float is new
  55      Ada.Wide_Text_IO.Float_Aux
  56        (Long_Long_Float, Scan_Long_Long_Float, Set_Image_Long_Long_Float);
  57
  58    package Aux_Float is new
  59      Ada.Wide_Text_IO.Complex_Aux (Float, Scalar_Float);
  60
  61    package Aux_Long_Float is new
  62      Ada.Wide_Text_IO.Complex_Aux (Long_Float, Scalar_Long_Float);
  63
  64    package Aux_Long_Long_Float is new
  65      Ada.Wide_Text_IO.Complex_Aux (Long_Long_Float, Scalar_Long_Long_Float);
  66
  67    --  Throughout this generic body, we distinguish between the case where type
  68    --  Float is OK, where type Long_Float is OK and where type Long_Long_Float
  69    --  is needed. These boolean constants are used to test for this, such that
  70    --  only code for the relevant case is included in the instance.
  71
  72    OK_Float : constant Boolean := Real'Base'Digits <= Float'Digits;
  73
  74    OK_Long_Float : constant Boolean := Real'Base'Digits <= Long_Float'Digits;
  75
  76    ---------
  77    -- Get --
  78    ---------
  79
  80    procedure Get
  81      (File  : File_Type;
  82       Item  : out Complex;
  83       Width : Field := 0)
  84    is
  85       Real_Item : Real'Base;
  86       Imag_Item : Real'Base;
  87
  88    begin
  89       if OK_Float then
  90          Aux_Float.Get (File, Float (Real_Item), Float (Imag_Item), Width);
  91       elsif OK_Long_Float then
  92          Aux_Long_Float.Get
  93            (File, Long_Float (Real_Item), Long_Float (Imag_Item), Width);
  94       else
  95          Aux_Long_Long_Float.Get
  96            (File, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
  97             Width);
  98       end if;
  99
 100       Item := (Real_Item, Imag_Item);
 101
 102    exception
 103       when Constraint_Error => raise Data_Error;
 104    end Get;
 105
 106    ---------
 107    -- Get --
 108    ---------
 109
 110    procedure Get
 111      (Item  : out Complex;
 112       Width : Field := 0)
 113    is
 114    begin
 115       Get (Current_In, Item, Width);
 116    end Get;
 117
 118    ---------
 119    -- Get --
 120    ---------
 121
 122    procedure Get
 123      (From : Wide_String;
 124       Item : out Complex;
 125       Last : out Positive)
 126    is
 127       Real_Item : Real'Base;
 128       Imag_Item : Real'Base;
 129
 130       S : constant String := Wide_String_To_String (From, WCEM_Upper);
 131       --  String on which we do the actual conversion. Note that the method
 132       --  used for wide character encoding is irrelevant, since if there is
 133       --  a character outside the Standard.Character range then the call to
 134       --  Aux.Gets will raise Data_Error in any case.
 135
 136    begin
 137       if OK_Float then
 138          Aux_Float.Gets (S, Float (Real_Item), Float (Imag_Item), Last);
 139       elsif OK_Long_Float then
 140          Aux_Long_Float.Gets
 141            (S, Long_Float (Real_Item), Long_Float (Imag_Item), Last);
 142       else
 143          Aux_Long_Long_Float.Gets
 144            (S, Long_Long_Float (Real_Item), Long_Long_Float (Imag_Item),
 145             Last);
 146       end if;
 147
 148       Item := (Real_Item, Imag_Item);
 149
 150    exception
 151       when Data_Error => raise Constraint_Error;
 152    end Get;
 153
 154    ---------
 155    -- Put --
 156    ---------
 157
 158    procedure Put
 159      (File : File_Type;
 160       Item : Complex;
 161       Fore : Field := Default_Fore;
 162       Aft  : Field := Default_Aft;
 163       Exp  : Field := Default_Exp)
 164    is
 165    begin
 166       if OK_Float then
 167          Aux_Float.Put
 168            (File, Float (Re (Item)), Float (Im (Item)), Fore, Aft, Exp);
 169       elsif OK_Long_Float then
 170          Aux_Long_Float.Put
 171            (File, Long_Float (Re (Item)), Long_Float (Im (Item)), Fore, Aft,
 172             Exp);
 173       else
 174          Aux_Long_Long_Float.Put
 175            (File, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
 176             Fore, Aft, Exp);
 177       end if;
 178    end Put;
 179
 180    ---------
 181    -- Put --
 182    ---------
 183
 184    procedure Put
 185      (Item : Complex;
 186       Fore : Field := Default_Fore;
 187       Aft  : Field := Default_Aft;
 188       Exp  : Field := Default_Exp)
 189    is
 190    begin
 191       Put (Current_Out, Item, Fore, Aft, Exp);
 192    end Put;
 193
 194    ---------
 195    -- Put --
 196    ---------
 197
 198    procedure Put
 199      (To   : out Wide_String;
 200       Item : Complex;
 201       Aft  : Field := Default_Aft;
 202       Exp  : Field := Default_Exp)
 203    is
 204       S : String (To'First .. To'Last);
 205
 206    begin
 207       if OK_Float then
 208          Aux_Float.Puts (S, Float (Re (Item)), Float (Im (Item)), Aft, Exp);
 209       elsif OK_Long_Float then
 210          Aux_Long_Float.Puts
 211            (S, Long_Float (Re (Item)), Long_Float (Im (Item)), Aft, Exp);
 212       else
 213          Aux_Long_Long_Float.Puts
 214            (S, Long_Long_Float (Re (Item)), Long_Long_Float (Im (Item)),
 215             Aft, Exp);
 216       end if;
 217
 218       for J in S'Range loop
 219          To (J) := Wide_Character'Val (Character'Pos (S (J)));
 220       end loop;
 221    end Put;
 222
 223 end Ada.Wide_Text_IO.Complex_IO;