gcc/ada/libgnat/a-ticoau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --              A D A . 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-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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  33
  34 package body Ada.Text_IO.Complex_Aux is
  35
  36    ---------
  37    -- Get --
  38    ---------
  39
  40    procedure Get
  41      (File  : File_Type;
  42       ItemR : out Num;
  43       ItemI : out Num;
  44       Width : Field)
  45    is
  46       Buf   : String (1 .. Field'Last);
  47       Stop  : Integer := 0;
  48       Ptr   : aliased Integer;
  49       Paren : Boolean := False;
  50
  51    begin
  52       --  General note for following code, exceptions from the calls to
  53       --  Get for components of the complex value are propagated.
  54
  55       if Width /= 0 then
  56          Load_Width (File, Width, Buf, Stop);
  57          Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr);
  58
  59          for J in Ptr + 1 .. Stop loop
  60             if not Is_Blank (Buf (J)) then
  61                raise Data_Error;
  62             end if;
  63          end loop;
  64
  65       --  Case of width = 0
  66
  67       else
  68          Load_Skip (File);
  69          Ptr := 0;
  70          Load (File, Buf, Ptr, '(', Paren);
  71          Aux.Get (File, ItemR, 0);
  72          Load_Skip (File);
  73          Load (File, Buf, Ptr, ',');
  74          Aux.Get (File, ItemI, 0);
  75
  76          if Paren then
  77             Load_Skip (File);
  78             Load (File, Buf, Ptr, ')', Paren);
  79
  80             if not Paren then
  81                raise Data_Error;
  82             end if;
  83          end if;
  84       end if;
  85    end Get;
  86
  87    ----------
  88    -- Gets --
  89    ----------
  90
  91    procedure Gets
  92      (From  : String;
  93       ItemR : out Num;
  94       ItemI : out Num;
  95       Last  : out Positive)
  96    is
  97       Paren : Boolean;
  98       Pos   : Integer;
  99
 100    begin
 101       String_Skip (From, Pos);
 102
 103       if From (Pos) = '(' then
 104          Pos := Pos + 1;
 105          Paren := True;
 106       else
 107          Paren := False;
 108       end if;
 109
 110       Aux.Gets (From (Pos .. From'Last), ItemR, Pos);
 111
 112       String_Skip (From (Pos + 1 .. From'Last), Pos);
 113
 114       if From (Pos) = ',' then
 115          Pos := Pos + 1;
 116       end if;
 117
 118       Aux.Gets (From (Pos .. From'Last), ItemI, Pos);
 119
 120       if Paren then
 121          String_Skip (From (Pos + 1 .. From'Last), Pos);
 122
 123          if From (Pos) /= ')' then
 124             raise Data_Error;
 125          end if;
 126       end if;
 127
 128       Last := Pos;
 129    end Gets;
 130
 131    ---------
 132    -- Put --
 133    ---------
 134
 135    procedure Put
 136      (File  : File_Type;
 137       ItemR : Num;
 138       ItemI : Num;
 139       Fore  : Field;
 140       Aft   : Field;
 141       Exp   : Field)
 142    is
 143    begin
 144       Put (File, '(');
 145       Aux.Put (File, ItemR, Fore, Aft, Exp);
 146       Put (File, ',');
 147       Aux.Put (File, ItemI, Fore, Aft, Exp);
 148       Put (File, ')');
 149    end Put;
 150
 151    ----------
 152    -- Puts --
 153    ----------
 154
 155    procedure Puts
 156      (To    : out String;
 157       ItemR : Num;
 158       ItemI : Num;
 159       Aft   : Field;
 160       Exp   : Field)
 161    is
 162       I_String : String (1 .. 3 * Field'Last);
 163       R_String : String (1 .. 3 * Field'Last);
 164
 165       Iptr : Natural;
 166       Rptr : Natural;
 167
 168    begin
 169       --  Both parts are initially converted with a Fore of 0
 170
 171       Rptr := 0;
 172       Aux.Set_Image (ItemR, R_String, Rptr, 0, Aft, Exp);
 173       Iptr := 0;
 174       Aux.Set_Image (ItemI, I_String, Iptr, 0, Aft, Exp);
 175
 176       --  Check room for both parts plus parens plus comma (RM G.1.3(34))
 177
 178       if Rptr + Iptr + 3 > To'Length then
 179          raise Layout_Error;
 180       end if;
 181
 182       --  If there is room, layout result according to (RM G.1.3(31-33))
 183
 184       To (To'First) := '(';
 185       To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr);
 186       To (To'First + Rptr + 1) := ',';
 187
 188       To (To'Last) := ')';
 189       To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr);
 190
 191       for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop
 192          To (J) := ' ';
 193       end loop;
 194
 195    end Puts;
 196
 197 end Ada.Text_IO.Complex_Aux;