gcc/ada/a-wtcoau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --         A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
  35 with Ada.Wide_Text_IO.Float_Aux;
  36
  37 with System.Img_Real; use System.Img_Real;
  38
  39 package body Ada.Wide_Text_IO.Complex_Aux is
  40
  41    package Aux renames Ada.Wide_Text_IO.Float_Aux;
  42
  43    ---------
  44    -- Get --
  45    ---------
  46
  47    procedure Get
  48      (File  : File_Type;
  49       ItemR : out Long_Long_Float;
  50       ItemI : out Long_Long_Float;
  51       Width : Field)
  52    is
  53       Buf   : String (1 .. Field'Last);
  54       Stop  : Integer := 0;
  55       Ptr   : aliased Integer;
  56       Paren : Boolean := False;
  57
  58    begin
  59       --  General note for following code, exceptions from the calls
  60       --  to Get for components of the complex value are propagated.
  61
  62       if Width /= 0 then
  63          Load_Width (File, Width, Buf, Stop);
  64          Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr);
  65
  66          for J in Ptr + 1 .. Stop loop
  67             if not Is_Blank (Buf (J)) then
  68                raise Data_Error;
  69             end if;
  70          end loop;
  71
  72       --  Case of width = 0
  73
  74       else
  75          Load_Skip (File);
  76          Ptr := 0;
  77          Load (File, Buf, Ptr, '(', Paren);
  78          Aux.Get (File, ItemR, 0);
  79          Load_Skip (File);
  80          Load (File, Buf, Ptr, ',');
  81          Aux.Get (File, ItemI, 0);
  82
  83          if Paren then
  84             Load_Skip (File);
  85             Load (File, Buf, Ptr, ')', Paren);
  86
  87             if not Paren then
  88                raise Data_Error;
  89             end if;
  90          end if;
  91       end if;
  92    end Get;
  93
  94    ----------
  95    -- Gets --
  96    ----------
  97
  98    procedure Gets
  99      (From  : String;
 100       ItemR : out Long_Long_Float;
 101       ItemI : out Long_Long_Float;
 102       Last  : out Positive)
 103    is
 104       Paren : Boolean;
 105       Pos   : Integer;
 106
 107    begin
 108       String_Skip (From, Pos);
 109
 110       if From (Pos) = '(' then
 111          Pos := Pos + 1;
 112          Paren := True;
 113       else
 114          Paren := False;
 115       end if;
 116
 117       Aux.Gets (From (Pos .. From'Last), ItemR, Pos);
 118
 119       String_Skip (From (Pos + 1 .. From'Last), Pos);
 120
 121       if From (Pos) = ',' then
 122          Pos := Pos + 1;
 123       end if;
 124
 125       Aux.Gets (From (Pos .. From'Last), ItemI, Pos);
 126
 127       if Paren then
 128          String_Skip (From (Pos + 1 .. From'Last), Pos);
 129
 130          if From (Pos) /= ')' then
 131             raise Data_Error;
 132          end if;
 133       end if;
 134
 135       Last := Pos;
 136    end Gets;
 137
 138    ---------
 139    -- Put --
 140    ---------
 141
 142    procedure Put
 143      (File  : File_Type;
 144       ItemR : Long_Long_Float;
 145       ItemI : Long_Long_Float;
 146       Fore  : Field;
 147       Aft   : Field;
 148       Exp   : Field)
 149    is
 150    begin
 151       Put (File, '(');
 152       Aux.Put (File, ItemR, Fore, Aft, Exp);
 153       Put (File, ',');
 154       Aux.Put (File, ItemI, Fore, Aft, Exp);
 155       Put (File, ')');
 156    end Put;
 157
 158    ----------
 159    -- Puts --
 160    ----------
 161
 162    procedure Puts
 163      (To    : out String;
 164       ItemR : Long_Long_Float;
 165       ItemI : Long_Long_Float;
 166       Aft   :  Field;
 167       Exp   :  Field)
 168    is
 169       I_String : String (1 .. 3 * Field'Last);
 170       R_String : String (1 .. 3 * Field'Last);
 171
 172       Iptr : Natural;
 173       Rptr : Natural;
 174
 175    begin
 176       --  Both parts are initially converted with a Fore of 0
 177
 178       Rptr := 0;
 179       Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp);
 180       Iptr := 0;
 181       Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp);
 182
 183       --  Check room for both parts plus parens plus comma (RM G.1.3(34))
 184
 185       if Rptr + Iptr + 3 > To'Length then
 186          raise Layout_Error;
 187       end if;
 188
 189       --  If there is room, layout result according to (RM G.1.3(31-33))
 190
 191       To (To'First) := '(';
 192       To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr);
 193       To (To'First + Rptr + 1) := ',';
 194
 195       To (To'Last) := ')';
 196
 197
 198       To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr);
 199
 200       for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop
 201          To (J) := ' ';
 202       end loop;
 203    end Puts;
 204
 205 end Ada.Wide_Text_IO.Complex_Aux;