1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . V A L U E _ N --
9 -- Copyright (C) 2021-2023, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Unchecked_Conversion
;
34 with System
.Val_Util
; use System
.Val_Util
;
36 package body System
.Value_N
is
38 function Value_Enumeration_Pos
40 Indexes
: System
.Address
;
41 Hash
: Hash_Function_Ptr
;
44 return Integer with Pure_Function
;
45 -- Same as Value_Enumeration, except returns negative if Value_Enumeration
46 -- would raise Constraint_Error.
48 ---------------------------
49 -- Value_Enumeration_Pos --
50 ---------------------------
52 function Value_Enumeration_Pos
54 Indexes
: System
.Address
;
55 Hash
: Hash_Function_Ptr
;
62 S
: String (Str
'Range) := Str
;
64 subtype Names_Index
is
65 Index_Type
range Index_Type
(Names
'First)
66 .. Index_Type
(Names
'Last) + 1;
67 subtype Index
is Natural range Natural'First .. Names
'Length;
68 type Index_Table
is array (Index
) of Names_Index
;
69 type Index_Table_Ptr
is access Index_Table
;
71 function To_Index_Table_Ptr
is
72 new Ada
.Unchecked_Conversion
(System
.Address
, Index_Table_Ptr
);
74 IndexesT
: constant Index_Table_Ptr
:= To_Index_Table_Ptr
(Indexes
);
76 pragma Assert
(Num
+ 1 in IndexesT
'Range);
79 Normalize_String
(S
, F
, L
);
82 Normal
: String renames S
(F
.. L
);
85 -- If we have a valid hash value, do a single lookup
87 H
:= (if Hash
/= null then Hash
.all (Normal
) else Natural'Last);
89 if H
/= Natural'Last then
91 (Natural (IndexesT
(H
)) ..
92 Natural (IndexesT
(H
+ 1)) - 1) = Normal
97 -- Otherwise do a linear search
100 for J
in 0 .. Num
loop
102 (Natural (IndexesT
(J
)) ..
103 Natural (IndexesT
(J
+ 1)) - 1) = Normal
112 end Value_Enumeration_Pos
;
114 -----------------------------
115 -- Valid_Value_Enumeration --
116 -----------------------------
118 function Valid_Value_Enumeration
120 Indexes
: System
.Address
;
121 Hash
: Hash_Function_Ptr
;
127 return Value_Enumeration_Pos
(Names
, Indexes
, Hash
, Num
, Str
) >= 0;
128 end Valid_Value_Enumeration
;
130 -----------------------
131 -- Value_Enumeration --
132 -----------------------
134 function Value_Enumeration
136 Indexes
: System
.Address
;
137 Hash
: Hash_Function_Ptr
;
142 Result
: constant Integer :=
143 Value_Enumeration_Pos
(Names
, Indexes
, Hash
, Num
, Str
);
146 -- The comparison eliminates the need for a range check on return
153 end Value_Enumeration
;