gcc/ada/libgnat/a-wtenau.adb

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