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