1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                  S Y S T E M . I M G _ E N U M _ N E W                   --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2000-2020, 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
32pragma Compiler_Unit_Warning;
33
34with Ada.Unchecked_Conversion;
35
36package body System.Img_Enum_New is
37
38   -------------------------
39   -- Image_Enumeration_8 --
40   -------------------------
41
42   procedure Image_Enumeration_8
43     (Pos     : Natural;
44      S       : in out String;
45      P       : out Natural;
46      Names   : String;
47      Indexes : System.Address)
48   is
49      pragma Assert (S'First = 1);
50
51      type Natural_8 is range 0 .. 2 ** 7 - 1;
52      subtype Names_Index is
53        Natural_8 range Natural_8 (Names'First)
54                          .. Natural_8 (Names'Last) + 1;
55      subtype Index is Natural range Natural'First .. Names'Length;
56      type Index_Table is array (Index) of Names_Index;
57      type Index_Table_Ptr is access Index_Table;
58
59      function To_Index_Table_Ptr is
60        new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
61
62      IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
63
64      pragma Assert (Pos in IndexesT'Range);
65      pragma Assert (Pos + 1 in IndexesT'Range);
66
67      Start : constant Natural := Natural (IndexesT (Pos));
68      Next  : constant Natural := Natural (IndexesT (Pos + 1));
69
70      pragma Assert (Next - 1 >= Start);
71      pragma Assert (Start >= Names'First);
72      pragma Assert (Next - 1 <= Names'Last);
73
74      pragma Assert (Next - Start <= S'Last);
75      --  The caller should guarantee that S is large enough to contain the
76      --  enumeration image.
77   begin
78      S (1 .. Next - Start) := Names (Start .. Next - 1);
79      P := Next - Start;
80   end Image_Enumeration_8;
81
82   --------------------------
83   -- Image_Enumeration_16 --
84   --------------------------
85
86   procedure Image_Enumeration_16
87     (Pos     : Natural;
88      S       : in out String;
89      P       : out Natural;
90      Names   : String;
91      Indexes : System.Address)
92   is
93      pragma Assert (S'First = 1);
94
95      type Natural_16 is range 0 .. 2 ** 15 - 1;
96      subtype Names_Index is
97        Natural_16 range Natural_16 (Names'First)
98                           .. Natural_16 (Names'Last) + 1;
99      subtype Index is Natural range Natural'First .. Names'Length;
100      type Index_Table is array (Index) of Names_Index;
101      type Index_Table_Ptr is access Index_Table;
102
103      function To_Index_Table_Ptr is
104        new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
105
106      IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
107
108      pragma Assert (Pos in IndexesT'Range);
109      pragma Assert (Pos + 1 in IndexesT'Range);
110
111      Start : constant Natural := Natural (IndexesT (Pos));
112      Next  : constant Natural := Natural (IndexesT (Pos + 1));
113
114      pragma Assert (Next - 1 >= Start);
115      pragma Assert (Start >= Names'First);
116      pragma Assert (Next - 1 <= Names'Last);
117
118      pragma Assert (Next - Start <= S'Last);
119      --  The caller should guarantee that S is large enough to contain the
120      --  enumeration image.
121   begin
122      S (1 .. Next - Start) := Names (Start .. Next - 1);
123      P := Next - Start;
124   end Image_Enumeration_16;
125
126   --------------------------
127   -- Image_Enumeration_32 --
128   --------------------------
129
130   procedure Image_Enumeration_32
131     (Pos     : Natural;
132      S       : in out String;
133      P       : out Natural;
134      Names   : String;
135      Indexes : System.Address)
136   is
137      pragma Assert (S'First = 1);
138
139      type Natural_32 is range 0 .. 2 ** 31 - 1;
140      subtype Names_Index is
141        Natural_32 range Natural_32 (Names'First)
142                           .. Natural_32 (Names'Last) + 1;
143      subtype Index is Natural range Natural'First .. Names'Length;
144      type Index_Table is array (Index) of Names_Index;
145      type Index_Table_Ptr is access Index_Table;
146
147      function To_Index_Table_Ptr is
148        new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
149
150      IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
151
152      pragma Assert (Pos in IndexesT'Range);
153      pragma Assert (Pos + 1 in IndexesT'Range);
154
155      Start : constant Natural := Natural (IndexesT (Pos));
156      Next  : constant Natural := Natural (IndexesT (Pos + 1));
157
158      pragma Assert (Next - 1 >= Start);
159      pragma Assert (Start >= Names'First);
160      pragma Assert (Next - 1 <= Names'Last);
161
162      pragma Assert (Next - Start <= S'Last);
163      --  The caller should guarantee that S is large enough to contain the
164      --  enumeration image.
165   begin
166      S (1 .. Next - Start) := Names (Start .. Next - 1);
167      P := Next - Start;
168   end Image_Enumeration_32;
169
170end System.Img_Enum_New;
171