gcc/ada/a-wtcoio.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME 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 --                                                                          --
  10 --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Wide_Text_IO.Complex_Aux;
  36 with System.WCh_Con; use System.WCh_Con;
  37 with System.WCh_WtS; use System.WCh_WtS;
  38
  39 with Ada.Unchecked_Conversion;
  40
  41 package body Ada.Wide_Text_IO.Complex_IO is
  42
  43    package Aux renames Ada.Wide_Text_IO.Complex_Aux;
  44
  45    subtype LLF is Long_Long_Float;
  46    --  Type used for calls to routines in Aux
  47
  48 --   subtype TFT is Ada.Wide_Text_IO.File_Type;
  49    --  File type required for calls to routines in Aux
  50
  51    function TFT is new
  52      Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type);
  53    --  This unchecked conversion is to get around a visibility bug in
  54    --  GNAT version 2.04w. It should be possible to simply use the
  55    --  subtype declared above and do normal checked conversions.
  56
  57    ---------
  58    -- Get --
  59    ---------
  60
  61    procedure Get
  62      (File  : in  File_Type;
  63       Item  : out Complex;
  64       Width : in  Field := 0)
  65    is
  66       Real_Item  : Real'Base;
  67       Imag_Item  : Real'Base;
  68
  69    begin
  70       Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width);
  71       Item := (Real_Item, Imag_Item);
  72
  73    exception
  74       when Constraint_Error => raise Data_Error;
  75    end Get;
  76
  77    ---------
  78    -- Get --
  79    ---------
  80
  81    procedure Get
  82      (Item  : out Complex;
  83       Width : in  Field := 0)
  84    is
  85    begin
  86       Get (Current_Input, Item, Width);
  87    end Get;
  88
  89    ---------
  90    -- Get --
  91    ---------
  92
  93    procedure Get
  94      (From : in  Wide_String;
  95       Item : out Complex;
  96       Last : out Positive)
  97    is
  98       Real_Item : Real'Base;
  99       Imag_Item : Real'Base;
 100
 101       S : constant String := Wide_String_To_String (From, WCEM_Upper);
 102       --  String on which we do the actual conversion. Note that the method
 103       --  used for wide character encoding is irrelevant, since if there is
 104       --  a character outside the Standard.Character range then the call to
 105       --  Aux.Gets will raise Data_Error in any case.
 106
 107    begin
 108       Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last);
 109       Item := (Real_Item, Imag_Item);
 110
 111    exception
 112       when Data_Error => raise Constraint_Error;
 113    end Get;
 114
 115    ---------
 116    -- Put --
 117    ---------
 118
 119    procedure Put
 120      (File : in File_Type;
 121       Item : in Complex;
 122       Fore : in Field := Default_Fore;
 123       Aft  : in Field := Default_Aft;
 124       Exp  : in Field := Default_Exp)
 125    is
 126    begin
 127       Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp);
 128    end Put;
 129
 130    ---------
 131    -- Put --
 132    ---------
 133
 134    procedure Put
 135      (Item : in Complex;
 136       Fore : in Field := Default_Fore;
 137       Aft  : in Field := Default_Aft;
 138       Exp  : in Field := Default_Exp)
 139    is
 140    begin
 141       Put (Current_Output, Item, Fore, Aft, Exp);
 142    end Put;
 143
 144    ---------
 145    -- Put --
 146    ---------
 147
 148    procedure Put
 149      (To   : out Wide_String;
 150       Item : in  Complex;
 151       Aft  : in  Field := Default_Aft;
 152       Exp  : in  Field := Default_Exp)
 153    is
 154       S : String (To'First .. To'Last);
 155
 156    begin
 157       Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp);
 158
 159       for J in S'Range loop
 160          To (J) := Wide_Character'Val (Character'Pos (S (J)));
 161       end loop;
 162    end Put;
 163
 164 end Ada.Wide_Text_IO.Complex_IO;