gcc/ada/a-tienau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --          A D A . 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 --                                                                          --
  10 --          Copyright (C) 1992-2001 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  36 with Ada.Characters.Handling; use Ada.Characters.Handling;
  37 with Interfaces.C_Streams;    use Interfaces.C_Streams;
  38
  39 --  Note: this package does not yet deal properly with wide characters ???
  40
  41 package body Ada.Text_IO.Enumeration_Aux is
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    --  These definitions replace the ones in Ada.Characters.Handling, which
  48    --  do not seem to work for some strange not understood reason ??? at
  49    --  least in the OS/2 version.
  50
  51    function To_Lower (C : Character) return Character;
  52    function To_Upper (C : Character) return Character;
  53
  54    ------------------
  55    -- Get_Enum_Lit --
  56    ------------------
  57
  58    procedure Get_Enum_Lit
  59      (File   : File_Type;
  60       Buf    : out String;
  61       Buflen : out Natural)
  62    is
  63       ch  : int;
  64       C   : Character;
  65
  66    begin
  67       Buflen := 0;
  68       Load_Skip (File);
  69       ch := Getc (File);
  70       C := Character'Val (ch);
  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 C = ''' then
  76          Store_Char (File, ch, Buf, Buflen);
  77
  78          ch := Getc (File);
  79
  80          if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
  81             Store_Char (File, ch, Buf, Buflen);
  82
  83             ch := Getc (File);
  84
  85             if ch = Character'Pos (''') then
  86                Store_Char (File, ch, Buf, Buflen);
  87             else
  88                Ungetc (ch, File);
  89             end if;
  90
  91          else
  92             Ungetc (ch, File);
  93          end if;
  94
  95       --  Similarly for identifiers, read as far as we can, in particular,
  96       --  do read a trailing underscore (again see ACVC test CE3905L to
  97       --  understand why we do this, although it seems somewhat peculiar).
  98
  99       else
 100          --  Identifier must start with a letter
 101
 102          if not Is_Letter (C) then
 103             Ungetc (ch, File);
 104             return;
 105          end if;
 106
 107          --  If we do have a letter, loop through the characters quitting on
 108          --  the first non-identifier character (note that this includes the
 109          --  cases of hitting a line mark or page mark).
 110
 111          loop
 112             C := Character'Val (ch);
 113             Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
 114
 115             ch := Getc (File);
 116             exit when ch = EOF;
 117             C := Character'Val (ch);
 118
 119             exit when not Is_Letter (C)
 120               and then not Is_Digit (C)
 121               and then C /= '_';
 122
 123             exit when C = '_'
 124               and then Buf (Buflen) = '_';
 125          end loop;
 126
 127          Ungetc (ch, File);
 128       end if;
 129    end Get_Enum_Lit;
 130
 131    ---------
 132    -- Put --
 133    ---------
 134
 135    procedure Put
 136      (File  : File_Type;
 137       Item  : String;
 138       Width : Field;
 139       Set   : Type_Set)
 140    is
 141       Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
 142
 143    begin
 144       if Set = Lower_Case and then Item (1) /= ''' then
 145          declare
 146             Iteml : String (Item'First .. Item'Last);
 147
 148          begin
 149             for J in Item'Range loop
 150                Iteml (J) := To_Lower (Item (J));
 151             end loop;
 152
 153             Put_Item (File, Iteml);
 154          end;
 155
 156       else
 157          Put_Item (File, Item);
 158       end if;
 159
 160       for J in 1 .. Actual_Width - Item'Length loop
 161          Put (File, ' ');
 162       end loop;
 163    end Put;
 164
 165    ----------
 166    -- Puts --
 167    ----------
 168
 169    procedure Puts
 170      (To    : out String;
 171       Item  : in String;
 172       Set   : Type_Set)
 173    is
 174       Ptr : Natural;
 175
 176    begin
 177       if Item'Length > To'Length then
 178          raise Layout_Error;
 179
 180       else
 181          Ptr := To'First;
 182          for J in Item'Range loop
 183             if Set = Lower_Case and then Item (1) /= ''' then
 184                To (Ptr) := To_Lower (Item (J));
 185             else
 186                To (Ptr) := Item (J);
 187             end if;
 188
 189             Ptr := Ptr + 1;
 190          end loop;
 191
 192          while Ptr <= To'Last loop
 193             To (Ptr) := ' ';
 194             Ptr := Ptr + 1;
 195          end loop;
 196       end if;
 197    end Puts;
 198
 199    -------------------
 200    -- Scan_Enum_Lit --
 201    -------------------
 202
 203    procedure Scan_Enum_Lit
 204      (From  : String;
 205       Start : out Natural;
 206       Stop  : out Natural)
 207    is
 208       C  : Character;
 209
 210    --  Processing for Scan_Enum_Lit
 211
 212    begin
 213       String_Skip (From, Start);
 214
 215       --  Character literal case. If the initial character is a quote, then
 216       --  we read as far as we can without backup (see ACVC test CE3905L
 217       --  which is for the analogous case for reading from a file).
 218
 219       if From (Start) = ''' then
 220          Stop := Start;
 221
 222          if Stop = From'Last then
 223             raise Data_Error;
 224          else
 225             Stop := Stop + 1;
 226          end if;
 227
 228          if From (Stop) in ' ' .. '~'
 229            or else From (Stop) >= Character'Val (16#80#)
 230          then
 231             if Stop = From'Last then
 232                raise Data_Error;
 233             else
 234                Stop := Stop + 1;
 235
 236                if From (Stop) = ''' then
 237                   return;
 238                end if;
 239             end if;
 240          end if;
 241
 242          Stop := Stop - 1;
 243          raise Data_Error;
 244
 245       --  Similarly for identifiers, read as far as we can, in particular,
 246       --  do read a trailing underscore (again see ACVC test CE3905L to
 247       --  understand why we do this, although it seems somewhat peculiar).
 248
 249       else
 250          --  Identifier must start with a letter
 251
 252          if not Is_Letter (From (Start)) then
 253             raise Data_Error;
 254          end if;
 255
 256          --  If we do have a letter, loop through the characters quitting on
 257          --  the first non-identifier character (note that this includes the
 258          --  cases of hitting a line mark or page mark).
 259
 260          Stop := Start;
 261          while Stop < From'Last loop
 262             C := From (Stop + 1);
 263
 264             exit when not Is_Letter (C)
 265               and then not Is_Digit (C)
 266               and then C /= '_';
 267
 268             exit when C = '_'
 269               and then From (Stop) = '_';
 270
 271             Stop := Stop + 1;
 272          end loop;
 273       end if;
 274
 275    end Scan_Enum_Lit;
 276
 277    --------------
 278    -- To_Lower --
 279    --------------
 280
 281    function To_Lower (C : Character) return Character is
 282    begin
 283       if C in 'A' .. 'Z' then
 284          return Character'Val (Character'Pos (C) + 32);
 285       else
 286          return C;
 287       end if;
 288    end To_Lower;
 289
 290    function To_Upper (C : Character) return Character is
 291    begin
 292       if C in 'a' .. 'z' then
 293          return Character'Val (Character'Pos (C) - 32);
 294       else
 295          return C;
 296       end if;
 297    end To_Upper;
 298
 299 end Ada.Text_IO.Enumeration_Aux;