1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ A U X --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Package containing utility procedures used throughout the compiler,
-- and also by ASIS so dependencies are limited to ASIS included packages.
-- Historical note. Many of the routines here were originally in Einfo, but
-- Einfo is supposed to be a relatively low level package dealing with the
-- content of entities in the tree, so this package is used for routines that
-- require more than minimal semantic knowledge.
with Alloc; use Alloc;
with Table;
with Types; use Types;
package Sem_Aux is
--------------------------------
-- Obsolescent Warnings Table --
--------------------------------
-- This table records entities for which a pragma Obsolescent with a
-- message argument has been processed.
type OWT_Record is record
Ent : Entity_Id;
-- The entity to which the pragma applies
Msg : String_Id;
-- The string containing the message
end record;
package Obsolescent_Warnings is new Table.Table (
Table_Component_Type => OWT_Record,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Obsolescent_Warnings_Initial,
Table_Increment => Alloc.Obsolescent_Warnings_Increment,
Table_Name => "Obsolescent_Warnings");
procedure Initialize;
-- Called at the start of compilation of each new main source file to
-- initialize the allocation of the Obsolescent_Warnings table. Note that
-- Initialize must not be called if Tree_Read is used.
procedure Tree_Read;
-- Initializes Obsolescent_Warnings table from current tree file using the
-- relevant Table.Tree_Read routine.
procedure Tree_Write;
-- Writes out Obsolescent_Warnings table to current tree file using the
-- relevant Table.Tree_Write routine.
-----------------
-- Subprograms --
-----------------
function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id;
-- The argument Id is a type or subtype entity. If the argument is a
-- subtype then it returns the subtype or type from which the subtype was
-- obtained, otherwise it returns Empty.
function Available_View (Typ : Entity_Id) return Entity_Id;
-- Typ is typically a type that has the With_Type flag set. Returns the
-- non-limited view of the type, if available, otherwise the type itself.
-- For class-wide types, there is no direct link in the tree, so we have
-- to retrieve the class-wide type of the non-limited view of the Etype.
-- Returns the argument unchanged if it is not one of these cases.
function Constant_Value (Ent : Entity_Id) return Node_Id;
-- Id is a variable, constant, named integer, or named real entity. This
-- call obtains the initialization expression for the entity. Will return
-- Empty for for a deferred constant whose full view is not available or
-- in some other cases of internal entities, which cannot be treated as
-- constants from the point of view of constant folding. Empty is also
-- returned for variables with no initialization expression.
function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- For any entity, Ent, returns the closest dynamic scope in which the
-- entity is declared or Standard_Standard for library-level entities
function First_Discriminant (Typ : Entity_Id) return Entity_Id;
-- Typ is a type with discriminants. The discriminants are the first
-- entities declared in the type, so normally this is equivalent to
-- First_Entity. The exception arises for tagged types, where the tag
-- itself is prepended to the front of the entity chain, so the
-- First_Discriminant function steps past the tag if it is present.
function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id;
-- Typ is a type with discriminants. Gives the first discriminant stored
-- in an object of this type. In many cases, these are the same as the
-- normal visible discriminants for the type, but in the case of renamed
-- discriminants, this is not always the case.
--
-- For tagged types, and untagged types which are root types or derived
-- types but which do not rename discriminants in their root type, the
-- stored discriminants are the same as the actual discriminants of the
-- type, and hence this function is the same as First_Discriminant.
--
-- For derived non-tagged types that rename discriminants in the root type
-- this is the first of the discriminants that occur in the root type. To
-- be precise, in this case stored discriminants are entities attached to
-- the entity chain of the derived type which are a copy of the
-- discriminants of the root type. Furthermore their Is_Completely_Hidden
-- flag is set since although they are actually stored in the object, they
-- are not in the set of discriminants that is visible in the type.
--
-- For derived untagged types, the set of stored discriminants are the real
-- discriminants from Gigi's standpoint, i.e. those that will be stored in
-- actual objects of the type.
function First_Subtype (Typ : Entity_Id) return Entity_Id;
-- Applies to all types and subtypes. For types, yields the first subtype
-- of the type. For subtypes, yields the first subtype of the base type of
-- the subtype.
function First_Tag_Component (Typ : Entity_Id) return Entity_Id;
-- Typ must be a tagged record type. This function returns the Entity for
-- the first _Tag field in the record type.
function Is_By_Copy_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by copy, as defined in (RM 6.2(3)).
function Is_By_Reference_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns True if Ent is a type entity where the type
-- is required to be passed by reference, as defined in (RM 6.2(4-9)).
function Is_Derived_Type (Ent : Entity_Id) return Boolean;
-- Determines if the given entity Ent is a derived type. Result is always
-- false if argument is not a type.
function Is_Generic_Formal (E : Entity_Id) return Boolean;
-- Determine whether E is a generic formal parameter. In particular this is
-- used to set the visibility of generic formals of a generic package
-- declared with a box or with partial parametrization.
function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Determines if given entity is an unconstrained array
-- type or subtype, a discriminated record type or subtype with no initial
-- discriminant values or a class wide type or subtype and returns True if
-- so. False for other type entities, or any entities that are not types.
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. True for a type that is "inherently" limited (i.e.
-- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
-- a part that is of a task, protected, or explicitly limited record type".
-- These are the types that are defined as return-by-reference types in Ada
-- 95 (see RM95-6.5(11-16)). In Ada 2005, these are the types that require
-- build-in-place for function calls. Note that build-in-place is allowed
-- for other types, too. This is also used for identifying pure procedures
-- whose calls should not be eliminated (RM 10.2.1(18/2)).
function Is_Limited_Type (Ent : Entity_Id) return Boolean;
-- Ent is any entity. Returns true if Ent is a limited type (limited
-- private type, limited interface type, task type, protected type,
-- composite containing a limited component, or a subtype of any of
-- these types).
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
-- Given a subtype Typ, this function finds out the nearest ancestor from
-- which constraints and predicates are inherited. There is no simple link
-- for doing this, consider:
--
-- subtype R is Integer range 1 .. 10;
-- type T is new R;
--
-- In this case the nearest ancestor is R, but the Etype of T'Base will
-- point to R'Base, so we have to go rummaging in the declarations to get
-- this information. It is used for making sure we freeze this before we
-- freeze Typ, and also for retrieving inherited predicate information.
-- For the case of base types or first subtypes, there is no useful entity
-- to return, so Empty is returned.
--
-- Note: this is similar to Ancestor_Subtype except that it also deals
-- with the case of derived types.
function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
-- This is similar to Enclosing_Dynamic_Scope except that if Ent is itself
-- a dynamic scope, then it is returned. Otherwise the result is the same
-- as that returned by Enclosing_Dynamic_Scope.
function Next_Tag_Component (Tag : Entity_Id) return Entity_Id;
-- Tag must be an entity representing a _Tag field of a tagged record.
-- The result returned is the next _Tag field in this record, or Empty
-- if this is the last such field.
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
pragma Inline (Ultimate_Alias);
-- Return the last entity in the chain of aliased entities of Prim. If Prim
-- has no alias return Prim.
end Sem_Aux;
|
