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-2021, 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
32with Ada.Text_IO.Enumeration_Aux;
33
34package 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
137end Ada.Text_IO.Enumeration_IO;
138