gcc/ada/libgnat/a-ztenau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                  ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
  33 with Ada.Characters.Conversions;        use Ada.Characters.Conversions;
  34 with Ada.Characters.Handling;           use Ada.Characters.Handling;
  35 with Interfaces.C_Streams;              use Interfaces.C_Streams;
  36 with System.WCh_Con;                    use System.WCh_Con;
  37
  38 package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
  39
  40    subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
  41    --  File type required for calls to routines in Aux
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    procedure Store_Char
  48      (WC  : Wide_Wide_Character;
  49       Buf : out Wide_Wide_String;
  50       Ptr : in out Integer);
  51    --  Store a single character in buffer, checking for overflow
  52
  53    --  These definitions replace the ones in Ada.Characters.Handling, which
  54    --  do not seem to work for some strange not understood reason ??? at
  55    --  least in the OS/2 version.
  56
  57    function To_Lower (C : Character) return Character;
  58
  59    ------------------
  60    -- Get_Enum_Lit --
  61    ------------------
  62
  63    procedure Get_Enum_Lit
  64      (File   : File_Type;
  65       Buf    : out Wide_Wide_String;
  66       Buflen : out Natural)
  67    is
  68       ch  : int;
  69       WC  : Wide_Wide_Character;
  70
  71    begin
  72       Buflen := 0;
  73       Load_Skip (TFT (File));
  74       ch := Nextc (TFT (File));
  75
  76       --  Character literal case. If the initial character is a quote, then
  77       --  we read as far as we can without backup (see ACVC test CE3905L)
  78
  79       if ch = Character'Pos (''') then
  80          Get (File, WC);
  81          Store_Char (WC, Buf, Buflen);
  82
  83          ch := Nextc (TFT (File));
  84
  85          if ch = LM or else ch = EOF then
  86             return;
  87          end if;
  88
  89          Get (File, WC);
  90          Store_Char (WC, Buf, Buflen);
  91
  92          ch := Nextc (TFT (File));
  93
  94          if ch /= Character'Pos (''') then
  95             return;
  96          end if;
  97
  98          Get (File, WC);
  99          Store_Char (WC, Buf, Buflen);
 100
 101       --  Similarly for identifiers, read as far as we can, in particular,
 102       --  do read a trailing underscore (again see ACVC test CE3905L to
 103       --  understand why we do this, although it seems somewhat peculiar).
 104
 105       else
 106          --  Identifier must start with a letter. Any wide character value
 107          --  outside the normal Latin-1 range counts as a letter for this.
 108
 109          if ch < 255 and then not Is_Letter (Character'Val (ch)) then
 110             return;
 111          end if;
 112
 113          --  If we do have a letter, loop through the characters quitting on
 114          --  the first non-identifier character (note that this includes the
 115          --  cases of hitting a line mark or page mark).
 116
 117          loop
 118             Get (File, WC);
 119             Store_Char (WC, Buf, Buflen);
 120
 121             ch := Nextc (TFT (File));
 122
 123             exit when ch = EOF;
 124
 125             if ch = Character'Pos ('_') then
 126                exit when Buf (Buflen) = '_';
 127
 128             elsif ch = Character'Pos (ASCII.ESC) then
 129                null;
 130
 131             elsif File.WC_Method in WC_Upper_Half_Encoding_Method
 132               and then ch > 127
 133             then
 134                null;
 135
 136             else
 137                exit when not Is_Letter (Character'Val (ch))
 138                            and then
 139                          not Is_Digit (Character'Val (ch));
 140             end if;
 141          end loop;
 142       end if;
 143    end Get_Enum_Lit;
 144
 145    ---------
 146    -- Put --
 147    ---------
 148
 149    procedure Put
 150      (File  : File_Type;
 151       Item  : Wide_Wide_String;
 152       Width : Field;
 153       Set   : Type_Set)
 154    is
 155       Actual_Width : constant Integer :=
 156         Integer'Max (Integer (Width), Item'Length);
 157
 158    begin
 159       Check_On_One_Line (TFT (File), Actual_Width);
 160
 161       if Set = Lower_Case and then Item (Item'First) /= ''' then
 162          declare
 163             Iteml : Wide_Wide_String (Item'First .. Item'Last);
 164
 165          begin
 166             for J in Item'Range loop
 167                if Is_Character (Item (J)) then
 168                   Iteml (J) :=
 169                     To_Wide_Wide_Character
 170                       (To_Lower (To_Character (Item (J))));
 171                else
 172                   Iteml (J) := Item (J);
 173                end if;
 174             end loop;
 175
 176             Put (File, Iteml);
 177          end;
 178
 179       else
 180          Put (File, Item);
 181       end if;
 182
 183       for J in 1 .. Actual_Width - Item'Length loop
 184          Put (File, ' ');
 185       end loop;
 186    end Put;
 187
 188    ----------
 189    -- Puts --
 190    ----------
 191
 192    procedure Puts
 193      (To   : out Wide_Wide_String;
 194       Item : Wide_Wide_String;
 195       Set  : Type_Set)
 196    is
 197       Ptr : Natural;
 198
 199    begin
 200       if Item'Length > To'Length then
 201          raise Layout_Error;
 202
 203       else
 204          Ptr := To'First;
 205          for J in Item'Range loop
 206             if Set = Lower_Case
 207               and then Item (Item'First) /= '''
 208               and then Is_Character (Item (J))
 209             then
 210                To (Ptr) :=
 211                  To_Wide_Wide_Character (To_Lower (To_Character (Item (J))));
 212             else
 213                To (Ptr) := Item (J);
 214             end if;
 215
 216             Ptr := Ptr + 1;
 217          end loop;
 218
 219          while Ptr <= To'Last loop
 220             To (Ptr) := ' ';
 221             Ptr := Ptr + 1;
 222          end loop;
 223       end if;
 224    end Puts;
 225
 226    -------------------
 227    -- Scan_Enum_Lit --
 228    -------------------
 229
 230    procedure Scan_Enum_Lit
 231      (From  : Wide_Wide_String;
 232       Start : out Natural;
 233       Stop  : out Natural)
 234    is
 235       WC  : Wide_Wide_Character;
 236
 237    --  Processing for Scan_Enum_Lit
 238
 239    begin
 240       Start := From'First;
 241
 242       loop
 243          if Start > From'Last then
 244             raise End_Error;
 245
 246          elsif Is_Character (From (Start))
 247            and then not Is_Blank (To_Character (From (Start)))
 248          then
 249             exit;
 250
 251          else
 252             Start := Start + 1;
 253          end if;
 254       end loop;
 255
 256       --  Character literal case. If the initial character is a quote, then
 257       --  we read as far as we can without backup (see ACVC test CE3905L
 258       --  which is for the analogous case for reading from a file).
 259
 260       if From (Start) = ''' then
 261          Stop := Start;
 262
 263          if Stop = From'Last then
 264             raise Data_Error;
 265          else
 266             Stop := Stop + 1;
 267          end if;
 268
 269          if From (Stop) in ' ' .. '~'
 270            or else From (Stop) >= Wide_Wide_Character'Val (16#80#)
 271          then
 272             if Stop = From'Last then
 273                raise Data_Error;
 274             else
 275                Stop := Stop + 1;
 276
 277                if From (Stop) = ''' then
 278                   return;
 279                end if;
 280             end if;
 281          end if;
 282
 283          raise Data_Error;
 284
 285       --  Similarly for identifiers, read as far as we can, in particular,
 286       --  do read a trailing underscore (again see ACVC test CE3905L to
 287       --  understand why we do this, although it seems somewhat peculiar).
 288
 289       else
 290          --  Identifier must start with a letter, any wide character outside
 291          --  the normal Latin-1 range is considered a letter for this test.
 292
 293          if Is_Character (From (Start))
 294            and then not Is_Letter (To_Character (From (Start)))
 295          then
 296             raise Data_Error;
 297          end if;
 298
 299          --  If we do have a letter, loop through the characters quitting on
 300          --  the first non-identifier character (note that this includes the
 301          --  cases of hitting a line mark or page mark).
 302
 303          Stop := Start + 1;
 304          while Stop < From'Last loop
 305             WC := From (Stop + 1);
 306
 307             exit when
 308               Is_Character (WC)
 309                 and then
 310                   not Is_Letter (To_Character (WC))
 311                 and then
 312                   not Is_Letter (To_Character (WC))
 313                 and then
 314                   (WC /= '_' or else From (Stop - 1) = '_');
 315
 316             Stop := Stop + 1;
 317          end loop;
 318       end if;
 319
 320    end Scan_Enum_Lit;
 321
 322    ----------------
 323    -- Store_Char --
 324    ----------------
 325
 326    procedure Store_Char
 327      (WC  : Wide_Wide_Character;
 328       Buf : out Wide_Wide_String;
 329       Ptr : in out Integer)
 330    is
 331    begin
 332       if Ptr = Buf'Last then
 333          raise Data_Error;
 334       else
 335          Ptr := Ptr + 1;
 336          Buf (Ptr) := WC;
 337       end if;
 338    end Store_Char;
 339
 340    --------------
 341    -- To_Lower --
 342    --------------
 343
 344    function To_Lower (C : Character) return Character is
 345    begin
 346       if C in 'A' .. 'Z' then
 347          return Character'Val (Character'Pos (C) + 32);
 348       else
 349          return C;
 350       end if;
 351    end To_Lower;
 352
 353 end Ada.Wide_Wide_Text_IO.Enumeration_Aux;