gcc/ada/a-tienio.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 _ I O            --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2015, 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.Enumeration_Aux;
  33
  34 package body Ada.Text_IO.Enumeration_IO is
  35
  36    package Aux renames Ada.Text_IO.Enumeration_Aux;
  37
  38    ---------
  39    -- Get --
  40    ---------
  41
  42    procedure Get (File : File_Type; Item : out Enum) is
  43       Buf    : String (1 .. Enum'Width + 1);
  44       Buflen : Natural;
  45
  46    begin
  47       Aux.Get_Enum_Lit (File, Buf, Buflen);
  48
  49       declare
  50          Buf_Str : String renames Buf (1 .. Buflen);
  51          pragma Unsuppress (Range_Check);
  52       begin
  53          Item := Enum'Value (Buf_Str);
  54       end;
  55
  56    exception
  57       when Constraint_Error => raise Data_Error;
  58    end Get;
  59
  60    procedure Get (Item : out Enum) is
  61       pragma Unsuppress (Range_Check);
  62    begin
  63       Get (Current_In, Item);
  64    end Get;
  65
  66    procedure Get
  67      (From : String;
  68       Item : out Enum;
  69       Last : out Positive)
  70    is
  71       Start : Natural;
  72
  73    begin
  74       Aux.Scan_Enum_Lit (From, Start, Last);
  75
  76       declare
  77          From_Str : String renames From (Start .. Last);
  78          pragma Unsuppress (Range_Check);
  79       begin
  80          Item := Enum'Value (From_Str);
  81       end;
  82
  83    exception
  84       when Constraint_Error => raise Data_Error;
  85    end Get;
  86
  87    ---------
  88    -- Put --
  89    ---------
  90
  91    procedure Put
  92      (File  : File_Type;
  93       Item  : Enum;
  94       Width : Field := Default_Width;
  95       Set   : Type_Set := Default_Setting)
  96    is
  97    begin
  98       --  Ensure that Item is valid before attempting to retrieve the Image, to
  99       --  prevent the possibility of out-of-bounds addressing of index or image
 100       --  tables. Units in the run-time library are normally compiled with
 101       --  checks suppressed, which includes instantiated generics.
 102
 103       if not Item'Valid then
 104          raise Constraint_Error with "invalid enumeration value";
 105       end if;
 106
 107       Aux.Put (File, Enum'Image (Item), Width, Set);
 108    end Put;
 109
 110    procedure Put
 111      (Item  : Enum;
 112       Width : Field := Default_Width;
 113       Set   : Type_Set := Default_Setting)
 114    is
 115    begin
 116       Put (Current_Out, Item, Width, Set);
 117    end Put;
 118
 119    procedure Put
 120      (To   : out String;
 121       Item : Enum;
 122       Set  : Type_Set := Default_Setting)
 123    is
 124    begin
 125       --  Ensure that Item is valid before attempting to retrieve the Image, to
 126       --  prevent the possibility of out-of-bounds addressing of index or image
 127       --  tables. Units in the run-time library are normally compiled with
 128       --  checks suppressed, which includes instantiated generics.
 129
 130       if not Item'Valid then
 131          raise Constraint_Error with "invalid enumeration value";
 132       end if;
 133
 134       Aux.Puts (To, Enum'Image (Item), Set);
 135    end Put;
 136
 137 end Ada.Text_IO.Enumeration_IO;