gcc/ada/a-tienau.adb

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