]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- R T S F I N D -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- |
19235870 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
19235870 RK |
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. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
19235870 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
19235870 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Atree; use Atree; |
27 | with Casing; use Casing; | |
28 | with Csets; use Csets; | |
29 | with Debug; use Debug; | |
30 | with Einfo; use Einfo; | |
76f9c7f4 | 31 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
32 | with Einfo.Utils; use Einfo.Utils; |
33 | with Elists; use Elists; | |
34 | with Errout; use Errout; | |
851e9f19 | 35 | with Exp_Dist; |
104f58db BD |
36 | with Fname; use Fname; |
37 | with Fname.UF; use Fname.UF; | |
38 | with Ghost; use Ghost; | |
39 | with Lib; use Lib; | |
40 | with Lib.Load; use Lib.Load; | |
41 | with Namet; use Namet; | |
42 | with Nlists; use Nlists; | |
43 | with Nmake; use Nmake; | |
44 | with Output; use Output; | |
45 | with Opt; use Opt; | |
46 | with Restrict; use Restrict; | |
47 | with Sem; use Sem; | |
48 | with Sem_Aux; use Sem_Aux; | |
49 | with Sem_Ch7; use Sem_Ch7; | |
50 | with Sem_Dist; use Sem_Dist; | |
51 | with Sem_Util; use Sem_Util; | |
52 | with Sinfo; use Sinfo; | |
53 | with Sinfo.Nodes; use Sinfo.Nodes; | |
54 | with Sinfo.Utils; use Sinfo.Utils; | |
55 | with Stand; use Stand; | |
56 | with Snames; use Snames; | |
57 | with Tbuild; use Tbuild; | |
58 | with Uname; use Uname; | |
19235870 RK |
59 | |
60 | package body Rtsfind is | |
61 | ||
fbf5a39b | 62 | RTE_Available_Call : Boolean := False; |
f937473f RD |
63 | -- Set True during call to RTE from RTE_Available (or from call to |
64 | -- RTE_Record_Component from RTE_Record_Component_Available). Tells | |
65 | -- the called subprogram to set RTE_Is_Available to False rather than | |
66 | -- generating an error message. | |
fbf5a39b AC |
67 | |
68 | RTE_Is_Available : Boolean; | |
69 | -- Set True by RTE_Available on entry. When RTE_Available_Call is set | |
70 | -- True, set False if RTE would otherwise generate an error message. | |
71 | ||
19235870 RK |
72 | ---------------- |
73 | -- Unit table -- | |
74 | ---------------- | |
75 | ||
76 | -- The unit table has one entry for each unit included in the definition | |
77 | -- of the type RTU_Id in the spec. The table entries are initialized in | |
78 | -- Initialize to set the Entity field to Empty, indicating that the | |
79 | -- corresponding unit has not yet been loaded. The fields are set when | |
80 | -- a unit is loaded to contain the defining entity for the unit, the | |
81 | -- unit name, and the unit number. | |
82 | ||
246d2ceb AC |
83 | -- Note that a unit can be loaded either by a call to find an entity |
84 | -- within the unit (e.g. RTE), or by an explicit with of the unit. In | |
85 | -- the latter case it is critical to make a call to Set_RTU_Loaded to | |
86 | -- ensure that the entry in this table reflects the load. | |
87 | ||
9af094a1 ES |
88 | -- A unit retrieved through rtsfind may end up in the context of several |
89 | -- other units, in addition to the main unit. These additional with_clauses | |
2cbac6c6 | 90 | -- are needed to generate a proper traversal order for CodePeer. To |
9af094a1 ES |
91 | -- minimize somewhat the redundancy created by numerous calls to rtsfind |
92 | -- from different units, we keep track of the list of implicit with_clauses | |
93 | -- already created for the current loaded unit. | |
991395ab | 94 | |
19235870 | 95 | type RT_Unit_Table_Record is record |
9af094a1 ES |
96 | Entity : Entity_Id; |
97 | Uname : Unit_Name_Type; | |
98 | First_Implicit_With : Node_Id; | |
99 | Unum : Unit_Number_Type; | |
19235870 RK |
100 | end record; |
101 | ||
102 | RT_Unit_Table : array (RTU_Id) of RT_Unit_Table_Record; | |
103 | ||
104 | -------------------------- | |
105 | -- Runtime Entity Table -- | |
106 | -------------------------- | |
107 | ||
108 | -- There is one entry in the runtime entity table for each entity that is | |
109 | -- included in the definition of the RE_Id type in the spec. The entries | |
110 | -- are set by Initialize_Rtsfind to contain Empty, indicating that the | |
111 | -- entity has not yet been located. Once the entity is located for the | |
112 | -- first time, its ID is stored in this array, so that subsequent calls | |
113 | -- for the same entity can be satisfied immediately. | |
114 | ||
f937473f | 115 | -- NOTE: In order to avoid conflicts between record components and subprgs |
276e95ca RW |
116 | -- that have the same name (i.e. subprogram External_Tag and |
117 | -- component External_Tag of package Ada.Tags) this table is not used | |
118 | -- with Record_Components. | |
f937473f | 119 | |
19235870 RK |
120 | RE_Table : array (RE_Id) of Entity_Id; |
121 | ||
991395ab AC |
122 | -------------------------------- |
123 | -- Generation of with_clauses -- | |
124 | -------------------------------- | |
19235870 | 125 | |
150bbaff | 126 | -- When a unit is implicitly loaded as a result of a call to RTE, it is |
991395ab AC |
127 | -- necessary to create one or two implicit with_clauses. We add such |
128 | -- with_clauses to the extended main unit if needed, and also to whatever | |
9af094a1 ES |
129 | -- unit needs them, which is not necessarily the main unit. The former |
130 | -- ensures that the object is correctly loaded by the binder. The latter | |
2cbac6c6 | 131 | -- is necessary for CodePeer. |
991395ab | 132 | |
9af094a1 ES |
133 | -- The field First_Implicit_With in the unit table record are used to |
134 | -- avoid creating duplicate with_clauses. | |
19235870 | 135 | |
99425ec3 AC |
136 | ---------------------------------------------- |
137 | -- Table of Predefined RE_Id Error Messages -- | |
138 | ---------------------------------------------- | |
139 | ||
140 | -- If an attempt is made to load an entity, given an RE_Id value, and the | |
141 | -- entity is not available in the current configuration, an error message | |
142 | -- is given (see Entity_Not_Defined below). The general form of such an | |
143 | -- error message is for example: | |
144 | ||
145 | -- entity "System.Pack_43.Bits_43" not defined | |
146 | ||
147 | -- The following table defines a set of RE_Id image values for which this | |
148 | -- error message is specialized and replaced by specific text indicating | |
149 | -- the exact message to be output. For example, in the case above, for the | |
150 | -- RE_Id value RE_Bits_43, we do indeed specialize the message, and the | |
151 | -- above generic message is replaced by: | |
152 | ||
153 | -- packed component size of 43 is not supported | |
154 | ||
155 | type CString_Ptr is access constant String; | |
156 | ||
157 | type PRE_Id_Entry is record | |
158 | Str : CString_Ptr; | |
159 | -- Pointer to string with the RE_Id image. The sequence ?? may appear | |
160 | -- in which case it will match any characters in the RE_Id image value. | |
161 | -- This is used to avoid the need for dozens of entries for RE_Bits_??. | |
162 | ||
163 | Msg : CString_Ptr; | |
164 | -- Pointer to string with the corresponding error text. The sequence | |
165 | -- ?? may appear, in which case, it is replaced by the corresponding | |
166 | -- sequence ?? in the Str value (if the first ? is zero, then it is | |
167 | -- omitted from the message). | |
168 | end record; | |
169 | ||
170 | Str1 : aliased constant String := "RE_BITS_??"; | |
171 | Str2 : aliased constant String := "RE_GET_??"; | |
172 | Str3 : aliased constant String := "RE_SET_??"; | |
173 | Str4 : aliased constant String := "RE_CALL_SIMPLE"; | |
174 | ||
175 | MsgPack : aliased constant String := | |
176 | "packed component size of ?? is not supported"; | |
177 | MsgRV : aliased constant String := | |
178 | "task rendezvous is not supported"; | |
179 | ||
180 | PRE_Id_Table : constant array (Natural range <>) of PRE_Id_Entry := | |
181 | (1 => (Str1'Access, MsgPack'Access), | |
182 | 2 => (Str2'Access, MsgPack'Access), | |
183 | 3 => (Str3'Access, MsgPack'Access), | |
184 | 4 => (Str4'Access, MsgRV'Access)); | |
185 | -- We will add entries to this table as we find cases where it is a good | |
186 | -- idea to do so. By no means all the RE_Id values need entries, because | |
187 | -- the expander often gives clear messages before it makes the Rtsfind | |
188 | -- call expecting to find the entity. | |
189 | ||
19235870 RK |
190 | ----------------------- |
191 | -- Local Subprograms -- | |
192 | ----------------------- | |
193 | ||
f937473f | 194 | function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id; |
150bbaff AC |
195 | -- Check entity Eid to ensure that configurable run-time restrictions are |
196 | -- met. May generate an error message (if RTE_Available_Call is false) and | |
197 | -- raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty). | |
e42bcfa3 | 198 | -- Also check that entity is not overloaded. |
f937473f | 199 | |
fbf5a39b | 200 | procedure Entity_Not_Defined (Id : RE_Id); |
150bbaff AC |
201 | -- Outputs error messages for an entity that is not defined in the run-time |
202 | -- library (the form of the error message is tailored for no run time or | |
99425ec3 AC |
203 | -- configurable run time mode as required). See also table of pre-defined |
204 | -- messages for entities above (RE_Id_Messages). | |
fbf5a39b | 205 | |
f937473f | 206 | function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type; |
150bbaff AC |
207 | -- Retrieves the Unit Name given a unit id represented by its enumeration |
208 | -- value in RTU_Id. | |
f937473f | 209 | |
fbf5a39b | 210 | procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id); |
d7761b2d | 211 | pragma No_Return (Load_Fail); |
276e95ca | 212 | -- Internal procedure called if we can't successfully locate or process a |
150bbaff AC |
213 | -- run-time unit. The parameters give information about the error message |
214 | -- to be given. S is a reason for failing to compile the file and U_Id is | |
215 | -- the unit id. RE_Id is the RE_Id originally passed to RTE. The message in | |
216 | -- S is one of the following: | |
fbf5a39b AC |
217 | -- |
218 | -- "not found" | |
219 | -- "had parser errors" | |
220 | -- "had semantic errors" | |
221 | -- | |
222 | -- The "not found" case is treated specially in that it is considered | |
01957849 AC |
223 | -- a normal situation in configurable run-time mode, and generates |
224 | -- a warning, but is otherwise ignored. | |
19235870 | 225 | |
fbf5a39b AC |
226 | procedure Load_RTU |
227 | (U_Id : RTU_Id; | |
228 | Id : RE_Id := RE_Null; | |
229 | Use_Setting : Boolean := False); | |
19235870 | 230 | -- Load the unit whose Id is given if not already loaded. The unit is |
aca53298 AC |
231 | -- loaded and analyzed, and the entry in RT_Unit_Table is updated to |
232 | -- reflect the load. Use_Setting is used to indicate the initial setting | |
233 | -- for the Is_Potentially_Use_Visible flag of the entity for the loaded | |
234 | -- unit (if it is indeed loaded). A value of False means nothing special | |
235 | -- need be done. A value of True indicates that this flag must be set to | |
2bd67690 RD |
236 | -- True. It is needed only in the Check_Text_IO_Special_Unit procedure, |
237 | -- which may materialize an entity of Text_IO (or [Wide_]Wide_Text_IO) that | |
238 | -- was previously unknown. Id is the RE_Id value of the entity which was | |
aca53298 AC |
239 | -- originally requested. Id is used only for error message detail, and if |
240 | -- it is RE_Null, then the attempt to output the entity name is ignored. | |
241 | ||
242 | function Make_Unit_Name | |
243 | (U : RT_Unit_Table_Record; | |
244 | N : Node_Id) return Node_Id; | |
f937473f RD |
245 | -- If the unit is a child unit, build fully qualified name for use in |
246 | -- With_Clause. | |
247 | ||
aca53298 | 248 | procedure Maybe_Add_With (U : in out RT_Unit_Table_Record); |
991395ab | 249 | -- If necessary, add an implicit with_clause from the current unit to the |
aca53298 | 250 | -- one represented by U. |
991395ab | 251 | |
fbf5a39b AC |
252 | procedure Output_Entity_Name (Id : RE_Id; Msg : String); |
253 | -- Output continuation error message giving qualified name of entity | |
99425ec3 | 254 | -- corresponding to Id, appending the string given by Msg. |
19235870 RK |
255 | |
256 | function RE_Chars (E : RE_Id) return Name_Id; | |
9de61fcb | 257 | -- Given a RE_Id value returns the Chars of the corresponding entity |
19235870 | 258 | |
fbf5a39b AC |
259 | procedure RTE_Error_Msg (Msg : String); |
260 | -- Generates a message by calling Error_Msg_N specifying Current_Error_Node | |
261 | -- as the node location using the given Msg text. Special processing in the | |
262 | -- case where RTE_Available_Call is set. In this case, no message is output | |
263 | -- and instead RTE_Is_Available is set to False. Note that this can only be | |
264 | -- used if you are sure that the message comes directly or indirectly from | |
265 | -- a call to the RTE function. | |
266 | ||
f937473f RD |
267 | --------------- |
268 | -- Check_CRT -- | |
269 | --------------- | |
270 | ||
271 | function Check_CRT (E : RE_Id; Eid : Entity_Id) return Entity_Id is | |
272 | U_Id : constant RTU_Id := RE_Unit_Table (E); | |
273 | ||
274 | begin | |
275 | if No (Eid) then | |
150bbaff AC |
276 | if RTE_Available_Call then |
277 | RTE_Is_Available := False; | |
278 | else | |
279 | Entity_Not_Defined (E); | |
280 | end if; | |
281 | ||
f937473f RD |
282 | raise RE_Not_Available; |
283 | ||
284 | -- Entity is available | |
285 | ||
286 | else | |
b2834fbd AC |
287 | -- If in No_Run_Time mode and entity is neither in the current unit |
288 | -- nor in one of the specially permitted units, raise the exception. | |
f937473f RD |
289 | |
290 | if No_Run_Time_Mode | |
291 | and then not OK_No_Run_Time_Unit (U_Id) | |
b2834fbd AC |
292 | |
293 | -- If the entity being referenced is defined in the current scope, | |
294 | -- using it is always fine as such usage can never introduce any | |
fba9ebfc AC |
295 | -- dependency on an additional unit. The presence of this test |
296 | -- helps generating meaningful error messages for CRT violations. | |
b2834fbd AC |
297 | |
298 | and then Scope (Eid) /= Current_Scope | |
f937473f RD |
299 | then |
300 | Entity_Not_Defined (E); | |
301 | raise RE_Not_Available; | |
302 | end if; | |
303 | ||
e42bcfa3 AC |
304 | -- Check entity is not overloaded, checking for special exceptions |
305 | ||
306 | if Has_Homonym (Eid) | |
307 | and then E /= RE_Save_Occurrence | |
308 | then | |
309 | Set_Standard_Error; | |
310 | Write_Str ("Run-time configuration error ("); | |
311 | Write_Str ("rtsfind entity """); | |
312 | Get_Decoded_Name_String (Chars (Eid)); | |
313 | Set_Casing (Mixed_Case); | |
314 | Write_Str (Name_Buffer (1 .. Name_Len)); | |
315 | Write_Str (""" is overloaded)"); | |
316 | Write_Eol; | |
317 | raise Unrecoverable_Error; | |
318 | end if; | |
319 | ||
f937473f RD |
320 | -- Otherwise entity is accessible |
321 | ||
322 | return Eid; | |
323 | end if; | |
324 | end Check_CRT; | |
325 | ||
2bd67690 RD |
326 | -------------------------------- |
327 | -- Check_Text_IO_Special_Unit -- | |
328 | -------------------------------- | |
329 | ||
330 | procedure Check_Text_IO_Special_Unit (Nam : Node_Id) is | |
331 | Chrs : Name_Id; | |
332 | ||
333 | type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id; | |
334 | ||
335 | Name_Map : constant Name_Map_Type := Name_Map_Type'( | |
336 | Name_Decimal_IO => Ada_Text_IO_Decimal_IO, | |
337 | Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO, | |
338 | Name_Fixed_IO => Ada_Text_IO_Fixed_IO, | |
339 | Name_Float_IO => Ada_Text_IO_Float_IO, | |
340 | Name_Integer_IO => Ada_Text_IO_Integer_IO, | |
341 | Name_Modular_IO => Ada_Text_IO_Modular_IO); | |
342 | ||
343 | Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( | |
344 | Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO, | |
345 | Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO, | |
346 | Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO, | |
347 | Name_Float_IO => Ada_Wide_Text_IO_Float_IO, | |
348 | Name_Integer_IO => Ada_Wide_Text_IO_Integer_IO, | |
349 | Name_Modular_IO => Ada_Wide_Text_IO_Modular_IO); | |
350 | ||
351 | Wide_Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'( | |
352 | Name_Decimal_IO => Ada_Wide_Wide_Text_IO_Decimal_IO, | |
353 | Name_Enumeration_IO => Ada_Wide_Wide_Text_IO_Enumeration_IO, | |
354 | Name_Fixed_IO => Ada_Wide_Wide_Text_IO_Fixed_IO, | |
355 | Name_Float_IO => Ada_Wide_Wide_Text_IO_Float_IO, | |
356 | Name_Integer_IO => Ada_Wide_Wide_Text_IO_Integer_IO, | |
357 | Name_Modular_IO => Ada_Wide_Wide_Text_IO_Modular_IO); | |
358 | ||
359 | To_Load : RTU_Id; | |
360 | -- Unit to be loaded, from one of the above maps | |
361 | ||
362 | begin | |
363 | -- Nothing to do if name is not an identifier or a selected component | |
364 | -- whose selector_name is an identifier. | |
365 | ||
366 | if Nkind (Nam) = N_Identifier then | |
367 | Chrs := Chars (Nam); | |
368 | ||
369 | elsif Nkind (Nam) = N_Selected_Component | |
370 | and then Nkind (Selector_Name (Nam)) = N_Identifier | |
371 | then | |
372 | Chrs := Chars (Selector_Name (Nam)); | |
373 | ||
374 | else | |
375 | return; | |
376 | end if; | |
377 | ||
378 | -- Nothing to do if name is not one of the Text_IO subpackages | |
379 | -- Otherwise look through loaded units, and if we find Text_IO | |
380 | -- or [Wide_]Wide_Text_IO already loaded, then load the proper child. | |
381 | ||
382 | if Chrs in Text_IO_Package_Name then | |
383 | for U in Main_Unit .. Last_Unit loop | |
384 | Get_Name_String (Unit_File_Name (U)); | |
385 | ||
386 | if Name_Len = 12 then | |
387 | ||
388 | -- Here is where we do the loads if we find one of the units | |
389 | -- Ada.Text_IO or Ada.[Wide_]Wide_Text_IO. An interesting | |
390 | -- detail is that these units may already be used (i.e. their | |
391 | -- In_Use flags may be set). Normally when the In_Use flag is | |
392 | -- set, the Is_Potentially_Use_Visible flag of all entities in | |
393 | -- the package is set, but the new entity we are mysteriously | |
394 | -- adding was not there to have its flag set at the time. So | |
395 | -- that's why we pass the extra parameter to RTU_Find, to make | |
396 | -- sure the flag does get set now. Given that those generic | |
397 | -- packages are in fact child units, we must indicate that | |
398 | -- they are visible. | |
399 | ||
400 | if Name_Buffer (1 .. 12) = "a-textio.ads" then | |
401 | To_Load := Name_Map (Chrs); | |
402 | ||
403 | elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then | |
404 | To_Load := Wide_Name_Map (Chrs); | |
405 | ||
406 | elsif Name_Buffer (1 .. 12) = "a-ztexio.ads" then | |
407 | To_Load := Wide_Wide_Name_Map (Chrs); | |
408 | ||
409 | else | |
410 | goto Continue; | |
411 | end if; | |
412 | ||
413 | Load_RTU (To_Load, Use_Setting => In_Use (Cunit_Entity (U))); | |
414 | Set_Is_Visible_Lib_Unit (RT_Unit_Table (To_Load).Entity); | |
415 | ||
416 | -- Prevent creation of an implicit 'with' from (for example) | |
417 | -- Ada.Wide_Text_IO.Integer_IO to Ada.Text_IO.Integer_IO, | |
418 | -- because these could create cycles. First check whether the | |
419 | -- simple names match ("integer_io" = "integer_io"), and then | |
420 | -- check whether the parent is indeed one of the | |
421 | -- [[Wide_]Wide_]Text_IO packages. | |
422 | ||
423 | if Chrs = Chars (Cunit_Entity (Current_Sem_Unit)) then | |
424 | declare | |
425 | Parent_Name : constant Unit_Name_Type := | |
426 | Get_Parent_Spec_Name | |
427 | (Unit_Name (Current_Sem_Unit)); | |
428 | ||
429 | begin | |
3ac06423 | 430 | if Present (Parent_Name) then |
2bd67690 RD |
431 | Get_Name_String (Parent_Name); |
432 | ||
433 | declare | |
434 | P : String renames Name_Buffer (1 .. Name_Len); | |
435 | begin | |
436 | if P = "ada.text_io%s" or else | |
437 | P = "ada.wide_text_io%s" or else | |
438 | P = "ada.wide_wide_text_io%s" | |
439 | then | |
440 | goto Continue; | |
441 | end if; | |
442 | end; | |
443 | end if; | |
444 | end; | |
445 | end if; | |
446 | ||
447 | -- Add an implicit with clause from the current unit to the | |
448 | -- [[Wide_]Wide_]Text_IO child (if necessary). | |
449 | ||
450 | Maybe_Add_With (RT_Unit_Table (To_Load)); | |
451 | end if; | |
452 | ||
453 | <<Continue>> null; | |
454 | end loop; | |
455 | end if; | |
456 | ||
457 | exception | |
458 | -- Generate error message if run-time unit not available | |
459 | ||
460 | when RE_Not_Available => | |
461 | Error_Msg_N ("& not available", Nam); | |
462 | end Check_Text_IO_Special_Unit; | |
463 | ||
9f4fd324 AC |
464 | ------------------------ |
465 | -- Entity_Not_Defined -- | |
466 | ------------------------ | |
467 | ||
468 | procedure Entity_Not_Defined (Id : RE_Id) is | |
469 | begin | |
470 | if No_Run_Time_Mode then | |
244e5a2c AC |
471 | |
472 | -- If the error occurs when compiling the body of a predefined | |
473 | -- unit for inlining purposes, the body must be illegal in this | |
474 | -- mode, and there is no point in continuing. | |
475 | ||
8ab31c0c | 476 | if In_Predefined_Unit (Current_Error_Node) then |
244e5a2c AC |
477 | Error_Msg_N |
478 | ("construct not allowed in no run time mode!", | |
479 | Current_Error_Node); | |
480 | raise Unrecoverable_Error; | |
481 | ||
482 | else | |
483 | RTE_Error_Msg ("|construct not allowed in no run time mode"); | |
484 | end if; | |
485 | ||
9f4fd324 AC |
486 | elsif Configurable_Run_Time_Mode then |
487 | RTE_Error_Msg ("|construct not allowed in this configuration>"); | |
488 | else | |
489 | RTE_Error_Msg ("run-time configuration error"); | |
490 | end if; | |
491 | ||
99425ec3 AC |
492 | -- See if this entry is to be found in the PRE_Id table that provides |
493 | -- specialized messages for some RE_Id values. | |
494 | ||
495 | for J in PRE_Id_Table'Range loop | |
496 | declare | |
497 | TStr : constant String := PRE_Id_Table (J).Str.all; | |
498 | RStr : constant String := RE_Id'Image (Id); | |
499 | TMsg : String := PRE_Id_Table (J).Msg.all; | |
500 | LMsg : Natural := TMsg'Length; | |
501 | ||
502 | begin | |
503 | if TStr'Length = RStr'Length then | |
504 | for J in TStr'Range loop | |
505 | if TStr (J) /= RStr (J) and then TStr (J) /= '?' then | |
506 | goto Continue; | |
507 | end if; | |
508 | end loop; | |
509 | ||
510 | for J in TMsg'First .. TMsg'Last - 1 loop | |
511 | if TMsg (J) = '?' then | |
512 | for K in 1 .. TStr'Last loop | |
513 | if TStr (K) = '?' then | |
514 | if RStr (K) = '0' then | |
515 | TMsg (J) := RStr (K + 1); | |
516 | TMsg (J + 1 .. LMsg - 1) := TMsg (J + 2 .. LMsg); | |
517 | LMsg := LMsg - 1; | |
518 | else | |
519 | TMsg (J .. J + 1) := RStr (K .. K + 1); | |
520 | end if; | |
521 | ||
522 | exit; | |
523 | end if; | |
524 | end loop; | |
525 | end if; | |
526 | end loop; | |
527 | ||
528 | RTE_Error_Msg (TMsg (1 .. LMsg)); | |
529 | return; | |
530 | end if; | |
531 | end; | |
532 | ||
533 | <<Continue>> null; | |
534 | end loop; | |
535 | ||
536 | -- We did not find an entry in the table, so output the generic entity | |
537 | -- not found message, where the name of the entity corresponds to the | |
538 | -- given RE_Id value. | |
539 | ||
9f4fd324 AC |
540 | Output_Entity_Name (Id, "not defined"); |
541 | end Entity_Not_Defined; | |
542 | ||
19235870 RK |
543 | ------------------- |
544 | -- Get_Unit_Name -- | |
545 | ------------------- | |
546 | ||
a2754419 BD |
547 | -- The following subtypes include all the proper descendants of each unit |
548 | -- that has such descendants. For example, Ada_Calendar_Descendant includes | |
549 | -- all the descendents of Ada.Calendar (except Ada.Calendar itself). These | |
550 | -- are used by Get_Unit_Name to know where to change "_" to ".", and by | |
551 | -- Is_Text_IO_Special_Package to detect the special generic pseudo-children | |
552 | -- of [[Wide_]Wide_]Text_IO. | |
553 | ||
554 | subtype Ada_Descendant is RTU_Id | |
555 | range Ada_Calendar .. Ada_Wide_Wide_Text_IO_Modular_IO; | |
556 | ||
557 | subtype Ada_Calendar_Descendant is Ada_Descendant | |
558 | range Ada_Calendar_Delays .. Ada_Calendar_Delays; | |
559 | ||
560 | subtype Ada_Dispatching_Descendant is Ada_Descendant | |
561 | range Ada_Dispatching_EDF .. Ada_Dispatching_EDF; | |
562 | ||
563 | subtype Ada_Interrupts_Descendant is Ada_Descendant range | |
564 | Ada_Interrupts_Names .. Ada_Interrupts_Names; | |
565 | ||
566 | subtype Ada_Numerics_Descendant is Ada_Descendant | |
567 | range Ada_Numerics_Generic_Elementary_Functions .. | |
568 | Ada_Numerics_Generic_Elementary_Functions; | |
569 | ||
570 | subtype Ada_Real_Time_Descendant is Ada_Descendant | |
571 | range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; | |
572 | ||
573 | subtype Ada_Streams_Descendant is Ada_Descendant | |
574 | range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO; | |
575 | ||
576 | subtype Ada_Strings_Descendant is Ada_Descendant | |
acc20d25 | 577 | range Ada_Strings_Superbounded .. Ada_Strings_Text_Output_Buffers; |
a2754419 BD |
578 | |
579 | subtype Ada_Strings_Text_Output_Descendant is Ada_Strings_Descendant | |
acc20d25 | 580 | range Ada_Strings_Text_Output_Utils .. Ada_Strings_Text_Output_Buffers; |
a2754419 BD |
581 | |
582 | subtype Ada_Text_IO_Descendant is Ada_Descendant | |
583 | range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; | |
584 | ||
585 | subtype Ada_Wide_Text_IO_Descendant is Ada_Descendant | |
586 | range Ada_Wide_Text_IO_Decimal_IO .. Ada_Wide_Text_IO_Modular_IO; | |
587 | ||
588 | subtype Ada_Wide_Wide_Text_IO_Descendant is Ada_Descendant | |
589 | range Ada_Wide_Wide_Text_IO_Decimal_IO .. | |
590 | Ada_Wide_Wide_Text_IO_Modular_IO; | |
591 | ||
ad1bea3a AC |
592 | subtype CUDA_Descendant is RTU_Id |
593 | range CUDA_Driver_Types .. CUDA_Vector_Types; | |
594 | ||
a2754419 | 595 | subtype Interfaces_Descendant is RTU_Id |
b0a16e6d GL |
596 | range Interfaces_C .. Interfaces_C_Strings; |
597 | ||
598 | subtype Interfaces_C_Descendant is Interfaces_Descendant | |
599 | range Interfaces_C_Strings .. Interfaces_C_Strings; | |
a2754419 BD |
600 | |
601 | subtype System_Descendant is RTU_Id | |
602 | range System_Address_Image .. System_Tasking_Stages; | |
603 | ||
604 | subtype System_Dim_Descendant is System_Descendant | |
605 | range System_Dim_Float_IO .. System_Dim_Integer_IO; | |
606 | ||
607 | subtype System_Multiprocessors_Descendant is System_Descendant | |
608 | range System_Multiprocessors_Dispatching_Domains .. | |
609 | System_Multiprocessors_Dispatching_Domains; | |
610 | ||
611 | subtype System_Storage_Pools_Descendant is System_Descendant | |
612 | range System_Storage_Pools_Subpools .. System_Storage_Pools_Subpools; | |
613 | ||
614 | subtype System_Strings_Descendant is System_Descendant | |
615 | range System_Strings_Stream_Ops .. System_Strings_Stream_Ops; | |
616 | ||
617 | subtype System_Tasking_Descendant is System_Descendant | |
618 | range System_Tasking_Async_Delays .. System_Tasking_Stages; | |
619 | ||
620 | subtype System_Tasking_Protected_Objects_Descendant is | |
621 | System_Tasking_Descendant | |
622 | range System_Tasking_Protected_Objects_Entries .. | |
623 | System_Tasking_Protected_Objects_Single_Entry; | |
624 | ||
625 | subtype System_Tasking_Restricted_Descendant is System_Tasking_Descendant | |
626 | range System_Tasking_Restricted_Stages .. | |
627 | System_Tasking_Restricted_Stages; | |
628 | ||
629 | subtype System_Tasking_Async_Delays_Descendant is System_Tasking_Descendant | |
630 | range System_Tasking_Async_Delays_Enqueue_Calendar .. | |
631 | System_Tasking_Async_Delays_Enqueue_RT; | |
632 | ||
19235870 RK |
633 | function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type is |
634 | Uname_Chars : constant String := RTU_Id'Image (U_Id); | |
19235870 RK |
635 | begin |
636 | Name_Len := Uname_Chars'Length; | |
637 | Name_Buffer (1 .. Name_Len) := Uname_Chars; | |
638 | Set_Casing (All_Lower_Case); | |
639 | ||
a2754419 | 640 | if U_Id in Ada_Descendant then |
19235870 RK |
641 | Name_Buffer (4) := '.'; |
642 | ||
a2754419 | 643 | if U_Id in Ada_Calendar_Descendant then |
19235870 RK |
644 | Name_Buffer (13) := '.'; |
645 | ||
a2754419 | 646 | elsif U_Id in Ada_Dispatching_Descendant then |
f2cbd970 JM |
647 | Name_Buffer (16) := '.'; |
648 | ||
a2754419 | 649 | elsif U_Id in Ada_Interrupts_Descendant then |
fbf5a39b AC |
650 | Name_Buffer (15) := '.'; |
651 | ||
a2754419 | 652 | elsif U_Id in Ada_Numerics_Descendant then |
98ee6f8d AC |
653 | Name_Buffer (13) := '.'; |
654 | ||
a2754419 | 655 | elsif U_Id in Ada_Real_Time_Descendant then |
19235870 RK |
656 | Name_Buffer (14) := '.'; |
657 | ||
a2754419 | 658 | elsif U_Id in Ada_Streams_Descendant then |
19235870 RK |
659 | Name_Buffer (12) := '.'; |
660 | ||
a2754419 | 661 | elsif U_Id in Ada_Strings_Descendant then |
6bde3eb5 AC |
662 | Name_Buffer (12) := '.'; |
663 | ||
a2754419 | 664 | if U_Id in Ada_Strings_Text_Output_Descendant then |
110d0820 BD |
665 | Name_Buffer (24) := '.'; |
666 | end if; | |
667 | ||
a2754419 | 668 | elsif U_Id in Ada_Text_IO_Descendant then |
19235870 RK |
669 | Name_Buffer (12) := '.'; |
670 | ||
a2754419 | 671 | elsif U_Id in Ada_Wide_Text_IO_Descendant then |
19235870 | 672 | Name_Buffer (17) := '.'; |
82c80734 | 673 | |
a2754419 | 674 | elsif U_Id in Ada_Wide_Wide_Text_IO_Descendant then |
82c80734 | 675 | Name_Buffer (22) := '.'; |
19235870 RK |
676 | end if; |
677 | ||
ad1bea3a AC |
678 | elsif U_Id in CUDA_Descendant then |
679 | Name_Buffer (5) := '.'; | |
680 | ||
a2754419 | 681 | elsif U_Id in Interfaces_Descendant then |
19235870 RK |
682 | Name_Buffer (11) := '.'; |
683 | ||
b0a16e6d GL |
684 | if U_Id in Interfaces_C_Descendant then |
685 | Name_Buffer (13) := '.'; | |
686 | end if; | |
687 | ||
a2754419 | 688 | elsif U_Id in System_Descendant then |
19235870 RK |
689 | Name_Buffer (7) := '.'; |
690 | ||
a2754419 | 691 | if U_Id in System_Dim_Descendant then |
98ee6f8d AC |
692 | Name_Buffer (11) := '.'; |
693 | end if; | |
694 | ||
a2754419 | 695 | if U_Id in System_Multiprocessors_Descendant then |
67645bde AC |
696 | Name_Buffer (23) := '.'; |
697 | end if; | |
698 | ||
a2754419 | 699 | if U_Id in System_Storage_Pools_Descendant then |
d3f70b35 AC |
700 | Name_Buffer (21) := '.'; |
701 | end if; | |
702 | ||
a2754419 | 703 | if U_Id in System_Strings_Descendant then |
f2cbd970 JM |
704 | Name_Buffer (15) := '.'; |
705 | end if; | |
706 | ||
a2754419 | 707 | if U_Id in System_Tasking_Descendant then |
19235870 RK |
708 | Name_Buffer (15) := '.'; |
709 | end if; | |
710 | ||
a2754419 | 711 | if U_Id in System_Tasking_Restricted_Descendant then |
19235870 RK |
712 | Name_Buffer (26) := '.'; |
713 | end if; | |
714 | ||
a2754419 | 715 | if U_Id in System_Tasking_Protected_Objects_Descendant then |
19235870 RK |
716 | Name_Buffer (33) := '.'; |
717 | end if; | |
718 | ||
a2754419 | 719 | if U_Id in System_Tasking_Async_Delays_Descendant then |
19235870 RK |
720 | Name_Buffer (28) := '.'; |
721 | end if; | |
722 | end if; | |
723 | ||
724 | -- Add %s at end for spec | |
725 | ||
726 | Name_Buffer (Name_Len + 1) := '%'; | |
727 | Name_Buffer (Name_Len + 2) := 's'; | |
728 | Name_Len := Name_Len + 2; | |
729 | ||
730 | return Name_Find; | |
731 | end Get_Unit_Name; | |
732 | ||
733 | ---------------- | |
734 | -- Initialize -- | |
735 | ---------------- | |
736 | ||
737 | procedure Initialize is | |
738 | begin | |
739 | -- Initialize the unit table | |
740 | ||
741 | for J in RTU_Id loop | |
742 | RT_Unit_Table (J).Entity := Empty; | |
28ccbd3f | 743 | RT_Unit_Table (J).First_Implicit_With := Empty; |
19235870 RK |
744 | end loop; |
745 | ||
746 | for J in RE_Id loop | |
747 | RE_Table (J) := Empty; | |
748 | end loop; | |
19f0526a AC |
749 | |
750 | RTE_Is_Available := False; | |
19235870 RK |
751 | end Initialize; |
752 | ||
753 | ------------ | |
754 | -- Is_RTE -- | |
755 | ------------ | |
756 | ||
757 | function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean is | |
758 | E_Unit_Name : Unit_Name_Type; | |
759 | Ent_Unit_Name : Unit_Name_Type; | |
760 | ||
761 | S : Entity_Id; | |
762 | E1 : Entity_Id; | |
763 | E2 : Entity_Id; | |
764 | ||
765 | begin | |
766 | if No (Ent) then | |
767 | return False; | |
768 | ||
769 | -- If E has already a corresponding entity, check it directly, | |
770 | -- going to full views if they exist to deal with the incomplete | |
771 | -- and private type cases properly. | |
772 | ||
773 | elsif Present (RE_Table (E)) then | |
774 | E1 := Ent; | |
775 | ||
776 | if Is_Type (E1) and then Present (Full_View (E1)) then | |
777 | E1 := Full_View (E1); | |
778 | end if; | |
779 | ||
780 | E2 := RE_Table (E); | |
781 | ||
782 | if Is_Type (E2) and then Present (Full_View (E2)) then | |
783 | E2 := Full_View (E2); | |
784 | end if; | |
785 | ||
786 | return E1 = E2; | |
787 | end if; | |
788 | ||
e42bcfa3 AC |
789 | -- If the unit containing E is not loaded, we already know that the |
790 | -- entity we have cannot have come from this unit. | |
19235870 RK |
791 | |
792 | E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E)); | |
793 | ||
794 | if not Is_Loaded (E_Unit_Name) then | |
795 | return False; | |
796 | end if; | |
797 | ||
798 | -- Here the unit containing the entity is loaded. We have not made | |
799 | -- an explicit call to RTE to get the entity in question, but we may | |
800 | -- have obtained a reference to it indirectly from some other entity | |
801 | -- in the same unit, or some other unit that references it. | |
802 | ||
803 | -- Get the defining unit of the entity | |
804 | ||
805 | S := Scope (Ent); | |
806 | ||
e7ba564f | 807 | if No (S) or else Ekind (S) /= E_Package then |
19235870 RK |
808 | return False; |
809 | end if; | |
810 | ||
811 | Ent_Unit_Name := Get_Unit_Name (Unit_Declaration_Node (S)); | |
812 | ||
813 | -- If the defining unit of the entity we are testing is not the | |
814 | -- unit containing E, then they cannot possibly match. | |
815 | ||
816 | if Ent_Unit_Name /= E_Unit_Name then | |
817 | return False; | |
818 | end if; | |
819 | ||
820 | -- If the units match, then compare the names (remember that no | |
821 | -- overloading is permitted in entities fetched using Rtsfind). | |
822 | ||
823 | if RE_Chars (E) = Chars (Ent) then | |
824 | RE_Table (E) := Ent; | |
825 | ||
826 | -- If front-end inlining is enabled, we may be within a body that | |
827 | -- contains inlined functions, which has not been retrieved through | |
828 | -- rtsfind, and therefore is not yet recorded in the RT_Unit_Table. | |
829 | -- Add the unit information now, it must be fully available. | |
830 | ||
831 | declare | |
832 | U : RT_Unit_Table_Record | |
fd22e260 | 833 | renames RT_Unit_Table (RE_Unit_Table (E)); |
19235870 RK |
834 | begin |
835 | if No (U.Entity) then | |
836 | U.Entity := S; | |
837 | U.Uname := E_Unit_Name; | |
838 | U.Unum := Get_Source_Unit (S); | |
839 | end if; | |
840 | end; | |
841 | ||
842 | return True; | |
843 | else | |
844 | return False; | |
845 | end if; | |
846 | end Is_RTE; | |
847 | ||
fbf5a39b AC |
848 | ------------ |
849 | -- Is_RTU -- | |
850 | ------------ | |
851 | ||
852 | function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is | |
853 | E : constant Entity_Id := RT_Unit_Table (U).Entity; | |
854 | begin | |
855 | return Present (E) and then E = Ent; | |
856 | end Is_RTU; | |
857 | ||
d1987ffd PT |
858 | -------------------------------- |
859 | -- Is_Text_IO_Special_Package -- | |
860 | -------------------------------- | |
861 | ||
862 | function Is_Text_IO_Special_Package (E : Entity_Id) return Boolean is | |
863 | begin | |
864 | pragma Assert (Is_Package_Or_Generic_Package (E)); | |
865 | ||
866 | -- ??? detection with a scope climbing might be more efficient | |
867 | ||
a2754419 | 868 | for U in Ada_Text_IO_Descendant loop |
d1987ffd PT |
869 | if Is_RTU (E, U) then |
870 | return True; | |
871 | end if; | |
872 | end loop; | |
873 | ||
a2754419 | 874 | for U in Ada_Wide_Text_IO_Descendant loop |
d1987ffd PT |
875 | if Is_RTU (E, U) then |
876 | return True; | |
877 | end if; | |
878 | end loop; | |
879 | ||
a2754419 | 880 | for U in Ada_Wide_Wide_Text_IO_Descendant loop |
d1987ffd PT |
881 | if Is_RTU (E, U) then |
882 | return True; | |
883 | end if; | |
884 | end loop; | |
885 | ||
886 | return False; | |
887 | end Is_Text_IO_Special_Package; | |
888 | ||
2bd67690 RD |
889 | ----------------------------- |
890 | -- Is_Text_IO_Special_Unit -- | |
891 | ----------------------------- | |
19235870 | 892 | |
2bd67690 | 893 | function Is_Text_IO_Special_Unit (Nam : Node_Id) return Boolean is |
19235870 RK |
894 | Prf : Node_Id; |
895 | Sel : Node_Id; | |
896 | ||
897 | begin | |
898 | if Nkind (Nam) /= N_Expanded_Name then | |
899 | return False; | |
900 | end if; | |
901 | ||
902 | Prf := Prefix (Nam); | |
903 | Sel := Selector_Name (Nam); | |
904 | ||
905 | if Nkind (Sel) /= N_Expanded_Name | |
906 | or else Nkind (Prf) /= N_Identifier | |
907 | or else Chars (Prf) /= Name_Ada | |
908 | then | |
909 | return False; | |
910 | end if; | |
911 | ||
912 | Prf := Prefix (Sel); | |
913 | Sel := Selector_Name (Sel); | |
914 | ||
915 | return | |
916 | Nkind (Prf) = N_Identifier | |
917 | and then | |
4a08c95c AC |
918 | Chars (Prf) in Name_Text_IO |
919 | | Name_Wide_Text_IO | |
920 | | Name_Wide_Wide_Text_IO | |
b69cd36a AC |
921 | and then Nkind (Sel) = N_Identifier |
922 | and then Chars (Sel) in Text_IO_Package_Name; | |
2bd67690 | 923 | end Is_Text_IO_Special_Unit; |
19235870 RK |
924 | |
925 | --------------- | |
926 | -- Load_Fail -- | |
927 | --------------- | |
928 | ||
fbf5a39b AC |
929 | procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is |
930 | M : String (1 .. 100); | |
931 | P : Natural := 0; | |
932 | ||
19235870 | 933 | begin |
fbf5a39b | 934 | -- Output header message |
19235870 | 935 | |
fbf5a39b AC |
936 | if Configurable_Run_Time_Mode then |
937 | RTE_Error_Msg ("construct not allowed in configurable run-time mode"); | |
938 | else | |
939 | RTE_Error_Msg ("run-time library configuration error"); | |
940 | end if; | |
19235870 | 941 | |
fbf5a39b | 942 | -- Output file name and reason string |
19235870 | 943 | |
01957849 AC |
944 | M (1 .. 6) := "\file "; |
945 | P := 6; | |
19235870 | 946 | |
01957849 AC |
947 | Get_Name_String |
948 | (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False)); | |
949 | M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); | |
950 | P := P + Name_Len; | |
19235870 | 951 | |
01957849 AC |
952 | M (P + 1) := ' '; |
953 | P := P + 1; | |
19235870 | 954 | |
01957849 AC |
955 | M (P + 1 .. P + S'Length) := S; |
956 | P := P + S'Length; | |
fbf5a39b | 957 | |
01957849 | 958 | RTE_Error_Msg (M (1 .. P)); |
fbf5a39b | 959 | |
01957849 | 960 | -- Output entity name |
fbf5a39b | 961 | |
01957849 | 962 | Output_Entity_Name (Id, "not available"); |
19235870 | 963 | |
150bbaff AC |
964 | -- In configurable run time mode, we raise RE_Not_Available, and the |
965 | -- caller is expected to deal gracefully with this. In the case of a | |
966 | -- call to RTE_Available, this exception will be caught in Rtsfind, | |
967 | -- and result in a returned value of False for the call. | |
d0dd5209 JM |
968 | |
969 | if Configurable_Run_Time_Mode then | |
970 | raise RE_Not_Available; | |
150bbaff AC |
971 | |
972 | -- Here we have a load failure in normal full run time mode. See if we | |
973 | -- are in the context of an RTE_Available call. If so, we just raise | |
974 | -- RE_Not_Available. This can happen if a unit is unavailable, which | |
975 | -- happens for example in the VM case, where the run-time is not | |
976 | -- complete, but we do not regard it as a configurable run-time. | |
977 | -- If the caller has done an explicit call to RTE_Available, then | |
978 | -- clearly the caller is prepared to deal with a result of False. | |
979 | ||
980 | elsif RTE_Available_Call then | |
981 | RTE_Is_Available := False; | |
982 | raise RE_Not_Available; | |
983 | ||
984 | -- If we are not in the context of an RTE_Available call, we are really | |
985 | -- trying to load an entity that is not there, and that should never | |
986 | -- happen, so in this case we signal a fatal error. | |
987 | ||
d0dd5209 JM |
988 | else |
989 | raise Unrecoverable_Error; | |
990 | end if; | |
19235870 RK |
991 | end Load_Fail; |
992 | ||
993 | -------------- | |
994 | -- Load_RTU -- | |
995 | -------------- | |
996 | ||
f9a8f910 HK |
997 | -- WARNING: This routine manages Ghost and SPARK regions. Return statements |
998 | -- must be replaced by gotos which jump to the end of the routine in order | |
999 | -- to restore the Ghost and SPARK modes. | |
1000 | ||
fbf5a39b AC |
1001 | procedure Load_RTU |
1002 | (U_Id : RTU_Id; | |
1003 | Id : RE_Id := RE_Null; | |
1004 | Use_Setting : Boolean := False) | |
1005 | is | |
19235870 | 1006 | U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); |
fbf5a39b | 1007 | Priv_Par : constant Elist_Id := New_Elmt_List; |
19235870 RK |
1008 | Lib_Unit : Node_Id; |
1009 | ||
1010 | procedure Save_Private_Visibility; | |
1011 | -- If the current unit is the body of child unit or the spec of a | |
cb736868 AC |
1012 | -- private child unit, the private declarations of the parent(s) are |
1013 | -- visible. If the unit to be loaded is another public sibling, its | |
1014 | -- compilation will affect the visibility of the common ancestors. | |
19235870 RK |
1015 | -- Indicate those that must be restored. |
1016 | ||
1017 | procedure Restore_Private_Visibility; | |
9de61fcb | 1018 | -- Restore the visibility of ancestors after compiling RTU |
19235870 RK |
1019 | |
1020 | -------------------------------- | |
1021 | -- Restore_Private_Visibility -- | |
1022 | -------------------------------- | |
1023 | ||
1024 | procedure Restore_Private_Visibility is | |
1025 | E_Par : Elmt_Id; | |
1026 | ||
1027 | begin | |
1028 | E_Par := First_Elmt (Priv_Par); | |
19235870 RK |
1029 | while Present (E_Par) loop |
1030 | if not In_Private_Part (Node (E_Par)) then | |
1031 | Install_Private_Declarations (Node (E_Par)); | |
1032 | end if; | |
1033 | ||
1034 | Next_Elmt (E_Par); | |
1035 | end loop; | |
1036 | end Restore_Private_Visibility; | |
1037 | ||
1038 | ----------------------------- | |
1039 | -- Save_Private_Visibility -- | |
1040 | ----------------------------- | |
1041 | ||
1042 | procedure Save_Private_Visibility is | |
1043 | Par : Entity_Id; | |
1044 | ||
1045 | begin | |
1046 | Par := Scope (Current_Scope); | |
19235870 RK |
1047 | while Present (Par) |
1048 | and then Par /= Standard_Standard | |
1049 | loop | |
1050 | if Ekind (Par) = E_Package | |
1051 | and then Is_Compilation_Unit (Par) | |
1052 | and then In_Private_Part (Par) | |
1053 | then | |
1054 | Append_Elmt (Par, Priv_Par); | |
1055 | end if; | |
1056 | ||
1057 | Par := Scope (Par); | |
1058 | end loop; | |
1059 | end Save_Private_Visibility; | |
1060 | ||
8636f52f HK |
1061 | -- Local variables |
1062 | ||
9057bd6a HK |
1063 | Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; |
1064 | Saved_IGR : constant Node_Id := Ignored_Ghost_Region; | |
93b3110d YM |
1065 | Saved_ISMP : constant Boolean := |
1066 | Ignore_SPARK_Mode_Pragmas_In_Instance; | |
9057bd6a HK |
1067 | Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; |
1068 | Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; | |
f9a8f910 | 1069 | -- Save Ghost and SPARK mode-related data to restore on exit |
8636f52f | 1070 | |
19235870 RK |
1071 | -- Start of processing for Load_RTU |
1072 | ||
1073 | begin | |
1074 | -- Nothing to do if unit is already loaded | |
1075 | ||
1076 | if Present (U.Entity) then | |
1077 | return; | |
1078 | end if; | |
1079 | ||
8636f52f HK |
1080 | -- Provide a clean environment for the unit |
1081 | ||
93b3110d | 1082 | Ignore_SPARK_Mode_Pragmas_In_Instance := False; |
9057bd6a HK |
1083 | Install_Ghost_Region (None, Empty); |
1084 | Install_SPARK_Mode (None, Empty); | |
8636f52f | 1085 | |
92219bab PB |
1086 | -- Otherwise we need to load the unit, First build unit name from the |
1087 | -- enumeration literal name in type RTU_Id. | |
19235870 | 1088 | |
9af094a1 | 1089 | U.Uname := Get_Unit_Name (U_Id); |
28ccbd3f | 1090 | U.First_Implicit_With := Empty; |
fbf5a39b | 1091 | |
92219bab PB |
1092 | -- Now do the load call, note that setting Error_Node to Empty is a |
1093 | -- signal to Load_Unit that we will regard a failure to find the file as | |
1094 | -- a fatal error, and that it should not output any kind of diagnostics, | |
1095 | -- since we will take care of it here. | |
19235870 | 1096 | |
3d63f8c9 | 1097 | -- We save style checking switches and turn off style checking for |
a90bd866 | 1098 | -- loading the unit, since we don't want any style checking. |
3d63f8c9 RD |
1099 | |
1100 | declare | |
1101 | Save_Style_Check : constant Boolean := Style_Check; | |
1102 | begin | |
1103 | Style_Check := False; | |
1104 | U.Unum := | |
1105 | Load_Unit | |
1106 | (Load_Name => U.Uname, | |
1107 | Required => False, | |
1108 | Subunit => False, | |
1109 | Error_Node => Empty); | |
1110 | Style_Check := Save_Style_Check; | |
1111 | end; | |
1112 | ||
1113 | -- Check for bad unit load | |
19235870 RK |
1114 | |
1115 | if U.Unum = No_Unit then | |
fbf5a39b | 1116 | Load_Fail ("not found", U_Id, Id); |
ef2c20e7 | 1117 | elsif Fatal_Error (U.Unum) = Error_Detected then |
fbf5a39b | 1118 | Load_Fail ("had parser errors", U_Id, Id); |
19235870 RK |
1119 | end if; |
1120 | ||
1121 | -- Make sure that the unit is analyzed | |
1122 | ||
1123 | declare | |
fbf5a39b AC |
1124 | Was_Analyzed : constant Boolean := |
1125 | Analyzed (Cunit (Current_Sem_Unit)); | |
19235870 RK |
1126 | |
1127 | begin | |
fbf5a39b AC |
1128 | -- Pretend that the current unit is analyzed, in case it is System |
1129 | -- or some such. This allows us to put some declarations, such as | |
1130 | -- exceptions and packed arrays of Boolean, into System even though | |
1131 | -- expanding them requires System... | |
19235870 RK |
1132 | |
1133 | -- This is a bit odd but works fine. If the RTS unit does not depend | |
1134 | -- in any way on the current unit, then it never gets back into the | |
1135 | -- current unit's tree, and the change we make to the current unit | |
1136 | -- tree is never noticed by anyone (it is undone in a moment). That | |
1137 | -- is the normal situation. | |
1138 | ||
1139 | -- If the RTS Unit *does* depend on the current unit, for instance, | |
1140 | -- when you are compiling System, then you had better have finished | |
d7f94401 AC |
1141 | -- analyzing the part of System that is depended on before you try to |
1142 | -- load the RTS Unit. This means having the code in System ordered in | |
1143 | -- an appropriate manner. | |
19235870 RK |
1144 | |
1145 | Set_Analyzed (Cunit (Current_Sem_Unit), True); | |
1146 | ||
1147 | if not Analyzed (Cunit (U.Unum)) then | |
19235870 | 1148 | |
991395ab | 1149 | -- If the unit is already loaded through a limited_with_clause, |
d0dd5209 JM |
1150 | -- the relevant entities must already be available. We do not |
1151 | -- want to load and analyze the unit because this would create | |
1152 | -- a real semantic dependence when the purpose of the limited_with | |
1153 | -- is precisely to avoid such. | |
1154 | ||
7b56a91b | 1155 | if From_Limited_With (Cunit_Entity (U.Unum)) then |
d0dd5209 JM |
1156 | null; |
1157 | ||
1158 | else | |
1159 | Save_Private_Visibility; | |
1160 | Semantics (Cunit (U.Unum)); | |
1161 | Restore_Private_Visibility; | |
1162 | ||
ef2c20e7 | 1163 | if Fatal_Error (U.Unum) = Error_Detected then |
d0dd5209 JM |
1164 | Load_Fail ("had semantic errors", U_Id, Id); |
1165 | end if; | |
19235870 RK |
1166 | end if; |
1167 | end if; | |
1168 | ||
1169 | -- Undo the pretence | |
1170 | ||
1171 | Set_Analyzed (Cunit (Current_Sem_Unit), Was_Analyzed); | |
1172 | end; | |
1173 | ||
1174 | Lib_Unit := Unit (Cunit (U.Unum)); | |
1175 | U.Entity := Defining_Entity (Lib_Unit); | |
1176 | ||
1177 | if Use_Setting then | |
1178 | Set_Is_Potentially_Use_Visible (U.Entity, True); | |
1179 | end if; | |
8636f52f | 1180 | |
93b3110d | 1181 | Ignore_SPARK_Mode_Pragmas_In_Instance := Saved_ISMP; |
9057bd6a HK |
1182 | Restore_Ghost_Region (Saved_GM, Saved_IGR); |
1183 | Restore_SPARK_Mode (Saved_SM, Saved_SMP); | |
19235870 RK |
1184 | end Load_RTU; |
1185 | ||
f937473f RD |
1186 | -------------------- |
1187 | -- Make_Unit_Name -- | |
1188 | -------------------- | |
1189 | ||
aca53298 AC |
1190 | function Make_Unit_Name |
1191 | (U : RT_Unit_Table_Record; | |
1192 | N : Node_Id) return Node_Id is | |
1193 | ||
f937473f RD |
1194 | Nam : Node_Id; |
1195 | Scop : Entity_Id; | |
1196 | ||
1197 | begin | |
e4494292 | 1198 | Nam := New_Occurrence_Of (U.Entity, Standard_Location); |
f937473f RD |
1199 | Scop := Scope (U.Entity); |
1200 | ||
1201 | if Nkind (N) = N_Defining_Program_Unit_Name then | |
1202 | while Scop /= Standard_Standard loop | |
1203 | Nam := | |
1204 | Make_Expanded_Name (Standard_Location, | |
1205 | Chars => Chars (U.Entity), | |
e4494292 | 1206 | Prefix => New_Occurrence_Of (Scop, Standard_Location), |
f937473f RD |
1207 | Selector_Name => Nam); |
1208 | Set_Entity (Nam, U.Entity); | |
1209 | ||
1210 | Scop := Scope (Scop); | |
1211 | end loop; | |
1212 | end if; | |
1213 | ||
1214 | return Nam; | |
1215 | end Make_Unit_Name; | |
1216 | ||
991395ab AC |
1217 | -------------------- |
1218 | -- Maybe_Add_With -- | |
1219 | -------------------- | |
1220 | ||
aca53298 | 1221 | procedure Maybe_Add_With (U : in out RT_Unit_Table_Record) is |
991395ab AC |
1222 | begin |
1223 | -- We do not need to generate a with_clause for a call issued from | |
76efd572 | 1224 | -- RTE_Component_Available. However, for CodePeer, we need these |
aca53298 | 1225 | -- additional with's, because for a sequence like "if RTE_Available (X) |
2cbac6c6 | 1226 | -- then ... RTE (X)" the RTE call fails to create some necessary with's. |
991395ab | 1227 | |
2cbac6c6 | 1228 | if RTE_Available_Call and not Generate_SCIL then |
aca53298 AC |
1229 | return; |
1230 | end if; | |
1231 | ||
1232 | -- Avoid creating directly self-referential with clauses | |
1233 | ||
1234 | if Current_Sem_Unit = U.Unum then | |
991395ab AC |
1235 | return; |
1236 | end if; | |
1237 | ||
5884c232 AC |
1238 | -- Add the with_clause, if we have not already added an implicit with |
1239 | -- for this unit to the current compilation unit. | |
991395ab | 1240 | |
9af094a1 ES |
1241 | declare |
1242 | LibUnit : constant Node_Id := Unit (Cunit (U.Unum)); | |
1243 | Clause : Node_Id; | |
1244 | Withn : Node_Id; | |
991395ab | 1245 | |
9af094a1 ES |
1246 | begin |
1247 | Clause := U.First_Implicit_With; | |
1248 | while Present (Clause) loop | |
1b1d88b1 | 1249 | if Parent (Clause) = Cunit (Current_Sem_Unit) then |
9af094a1 ES |
1250 | return; |
1251 | end if; | |
991395ab | 1252 | |
9af094a1 ES |
1253 | Clause := Next_Implicit_With (Clause); |
1254 | end loop; | |
991395ab | 1255 | |
9af094a1 | 1256 | Withn := |
94ce4941 HK |
1257 | Make_With_Clause (Standard_Location, |
1258 | Name => | |
1259 | Make_Unit_Name | |
1260 | (U, Defining_Unit_Name (Specification (LibUnit)))); | |
991395ab | 1261 | |
9af094a1 | 1262 | Set_Corresponding_Spec (Withn, U.Entity); |
94ce4941 HK |
1263 | Set_First_Name (Withn); |
1264 | Set_Implicit_With (Withn); | |
1265 | Set_Library_Unit (Withn, Cunit (U.Unum)); | |
9af094a1 | 1266 | Set_Next_Implicit_With (Withn, U.First_Implicit_With); |
991395ab | 1267 | |
9af094a1 | 1268 | U.First_Implicit_With := Withn; |
991395ab AC |
1269 | |
1270 | Mark_Rewrite_Insertion (Withn); | |
1271 | Append (Withn, Context_Items (Cunit (Current_Sem_Unit))); | |
1272 | Check_Restriction_No_Dependence (Name (Withn), Current_Error_Node); | |
1273 | end; | |
1274 | end Maybe_Add_With; | |
1275 | ||
1276 | ------------------------ | |
fbf5a39b AC |
1277 | -- Output_Entity_Name -- |
1278 | ------------------------ | |
1279 | ||
1280 | procedure Output_Entity_Name (Id : RE_Id; Msg : String) is | |
1281 | M : String (1 .. 2048); | |
1282 | P : Natural := 0; | |
1283 | -- M (1 .. P) is current message to be output | |
1284 | ||
1285 | RE_Image : constant String := RE_Id'Image (Id); | |
7504523e AC |
1286 | S : Natural; |
1287 | -- RE_Image (S .. RE_Image'Last) is the name of the entity without the | |
1288 | -- "RE_" or "RO_XX_" prefix. | |
fbf5a39b AC |
1289 | |
1290 | begin | |
01957849 | 1291 | if Id = RE_Null then |
fbf5a39b AC |
1292 | return; |
1293 | end if; | |
1294 | ||
1295 | M (1 .. 9) := "\entity """; | |
1296 | P := 9; | |
1297 | ||
1298 | -- Add unit name to message, excluding %s or %b at end | |
1299 | ||
1300 | Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id))); | |
1301 | Name_Len := Name_Len - 2; | |
1302 | Set_Casing (Mixed_Case); | |
1303 | M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); | |
1304 | P := P + Name_Len; | |
1305 | ||
1306 | -- Add a qualifying period | |
1307 | ||
1308 | M (P + 1) := '.'; | |
1309 | P := P + 1; | |
1310 | ||
f31dcd99 | 1311 | -- Strip "RE" |
fbf5a39b | 1312 | |
7504523e | 1313 | if RE_Image (2) = 'E' then |
7504523e | 1314 | S := 4; |
f31dcd99 HK |
1315 | |
1316 | -- Strip "RO_XX" | |
1317 | ||
7504523e | 1318 | else |
7504523e AC |
1319 | S := 7; |
1320 | end if; | |
f31dcd99 HK |
1321 | |
1322 | -- Add entity name and closing quote to message | |
1323 | ||
7504523e AC |
1324 | Name_Len := RE_Image'Length - S + 1; |
1325 | Name_Buffer (1 .. Name_Len) := RE_Image (S .. RE_Image'Last); | |
fbf5a39b AC |
1326 | Set_Casing (Mixed_Case); |
1327 | M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); | |
1328 | P := P + Name_Len; | |
1329 | M (P + 1) := '"'; | |
1330 | P := P + 1; | |
1331 | ||
1332 | -- Add message | |
1333 | ||
1334 | M (P + 1) := ' '; | |
1335 | P := P + 1; | |
1336 | M (P + 1 .. P + Msg'Length) := Msg; | |
1337 | P := P + Msg'Length; | |
1338 | ||
1339 | -- Output message at current error node location | |
1340 | ||
1341 | RTE_Error_Msg (M (1 .. P)); | |
1342 | end Output_Entity_Name; | |
1343 | ||
19235870 RK |
1344 | -------------- |
1345 | -- RE_Chars -- | |
1346 | -------------- | |
1347 | ||
1348 | function RE_Chars (E : RE_Id) return Name_Id is | |
1349 | RE_Name_Chars : constant String := RE_Id'Image (E); | |
1350 | ||
1351 | begin | |
1352 | -- Copy name skipping initial RE_ or RO_XX characters | |
1353 | ||
1354 | if RE_Name_Chars (1 .. 2) = "RE" then | |
1355 | for J in 4 .. RE_Name_Chars'Last loop | |
1356 | Name_Buffer (J - 3) := Fold_Lower (RE_Name_Chars (J)); | |
1357 | end loop; | |
1358 | ||
1359 | Name_Len := RE_Name_Chars'Length - 3; | |
1360 | ||
1361 | else | |
1362 | for J in 7 .. RE_Name_Chars'Last loop | |
1363 | Name_Buffer (J - 6) := Fold_Lower (RE_Name_Chars (J)); | |
1364 | end loop; | |
1365 | ||
1366 | Name_Len := RE_Name_Chars'Length - 6; | |
1367 | end if; | |
1368 | ||
1369 | return Name_Find; | |
1370 | end RE_Chars; | |
1371 | ||
1372 | --------- | |
1373 | -- RTE -- | |
1374 | --------- | |
1375 | ||
1376 | function RTE (E : RE_Id) return Entity_Id is | |
19235870 RK |
1377 | procedure Check_RPC; |
1378 | -- Reject programs that make use of distribution features not supported | |
7a5b62b0 AC |
1379 | -- on the current target. Also check that the PCS is compatible with the |
1380 | -- code generator version. On such targets (Vxworks, others?) we provide | |
1381 | -- a minimal body for System.Rpc that only supplies an implementation of | |
1382 | -- Partition_Id. | |
19235870 RK |
1383 | |
1384 | function Find_Local_Entity (E : RE_Id) return Entity_Id; | |
1385 | -- This function is used when entity E is in this compilation's main | |
1386 | -- unit. It gets the value from the already compiled declaration. | |
1387 | ||
19235870 RK |
1388 | --------------- |
1389 | -- Check_RPC -- | |
1390 | --------------- | |
1391 | ||
1392 | procedure Check_RPC is | |
19235870 RK |
1393 | begin |
1394 | -- Bypass this check if debug flag -gnatdR set | |
1395 | ||
1396 | if Debug_Flag_RR then | |
1397 | return; | |
1398 | end if; | |
1399 | ||
706d7459 TQ |
1400 | -- Otherwise we need the check if we are going after one of the |
1401 | -- critical entities in System.RPC / System.Partition_Interface. | |
1402 | ||
1403 | if E = RE_Do_Rpc | |
1404 | or else | |
1405 | E = RE_Do_Apc | |
1406 | or else | |
1407 | E = RE_Params_Stream_Type | |
1408 | or else | |
1409 | E = RE_Request_Access | |
19235870 | 1410 | then |
706d7459 TQ |
1411 | -- If generating RCI stubs, check that we have a real PCS |
1412 | ||
1413 | if (Distribution_Stub_Mode = Generate_Receiver_Stub_Body | |
1414 | or else | |
1415 | Distribution_Stub_Mode = Generate_Caller_Stub_Body) | |
1416 | and then Get_PCS_Name = Name_No_DSA | |
1417 | then | |
1418 | Set_Standard_Error; | |
1419 | Write_Str ("distribution feature not supported"); | |
1420 | Write_Eol; | |
1421 | raise Unrecoverable_Error; | |
1422 | ||
1423 | -- In all cases, check Exp_Dist and System.Partition_Interface | |
1424 | -- consistency. | |
33c423c8 | 1425 | |
d693e39d TQ |
1426 | elsif Get_PCS_Version /= |
1427 | Exp_Dist.PCS_Version_Number (Get_PCS_Name) | |
1428 | then | |
706d7459 TQ |
1429 | Set_Standard_Error; |
1430 | Write_Str ("PCS version mismatch: expander "); | |
1431 | Write_Int (Exp_Dist.PCS_Version_Number (Get_PCS_Name)); | |
1432 | Write_Str (", PCS ("); | |
1433 | Write_Name (Get_PCS_Name); | |
1434 | Write_Str (") "); | |
1435 | Write_Int (Get_PCS_Version); | |
1436 | Write_Eol; | |
1437 | raise Unrecoverable_Error; | |
33c423c8 | 1438 | end if; |
19235870 RK |
1439 | end if; |
1440 | end Check_RPC; | |
1441 | ||
f937473f RD |
1442 | ----------------------- |
1443 | -- Find_Local_Entity -- | |
1444 | ----------------------- | |
19235870 RK |
1445 | |
1446 | function Find_Local_Entity (E : RE_Id) return Entity_Id is | |
d0dd5209 JM |
1447 | RE_Str : constant String := RE_Id'Image (E); |
1448 | Nam : Name_Id; | |
19235870 RK |
1449 | Ent : Entity_Id; |
1450 | ||
1451 | Save_Nam : constant String := Name_Buffer (1 .. Name_Len); | |
1452 | -- Save name buffer and length over call | |
1453 | ||
1454 | begin | |
1455 | Name_Len := Natural'Max (0, RE_Str'Length - 3); | |
1456 | Name_Buffer (1 .. Name_Len) := | |
1457 | RE_Str (RE_Str'First + 3 .. RE_Str'Last); | |
1458 | ||
d0dd5209 | 1459 | Nam := Name_Find; |
ac16e74c | 1460 | Ent := Entity_Id (Get_Name_Table_Int (Nam)); |
19235870 RK |
1461 | |
1462 | Name_Len := Save_Nam'Length; | |
1463 | Name_Buffer (1 .. Name_Len) := Save_Nam; | |
1464 | ||
1465 | return Ent; | |
1466 | end Find_Local_Entity; | |
1467 | ||
92219bab PB |
1468 | -- Local variables |
1469 | ||
1470 | U_Id : constant RTU_Id := RE_Unit_Table (E); | |
1471 | U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); | |
1472 | ||
1473 | Ename : Name_Id; | |
1474 | Lib_Unit : Node_Id; | |
1475 | Pkg_Ent : Entity_Id; | |
1476 | ||
1477 | Save_Front_End_Inlining : constant Boolean := Front_End_Inlining; | |
1478 | -- This flag is used to disable front-end inlining when RTE is invoked. | |
1479 | -- This prevents the analysis of other runtime bodies when a particular | |
1480 | -- spec is loaded through Rtsfind. This is both efficient, and prevents | |
1481 | -- spurious visibility conflicts between use-visible user entities, and | |
1482 | -- entities in run-time packages. | |
1483 | ||
19235870 RK |
1484 | -- Start of processing for RTE |
1485 | ||
1486 | begin | |
1487 | -- Doing a rtsfind in system.ads is special, as we cannot do this | |
1488 | -- when compiling System itself. So if we are compiling system then | |
1489 | -- we should already have acquired and processed the declaration | |
1490 | -- of the entity. The test is to see if this compilation's main unit | |
1491 | -- is System. If so, return the value from the already compiled | |
1492 | -- declaration and otherwise do a regular find. | |
1493 | ||
ea1135b8 | 1494 | -- Not pleasant, but these kinds of annoying recursion scenarios when |
a90bd866 | 1495 | -- writing an Ada compiler in Ada have to be broken somewhere. |
19235870 RK |
1496 | |
1497 | if Present (Main_Unit_Entity) | |
1498 | and then Chars (Main_Unit_Entity) = Name_System | |
1499 | and then Analyzed (Main_Unit_Entity) | |
1500 | and then not Is_Child_Unit (Main_Unit_Entity) | |
1501 | then | |
f937473f | 1502 | return Check_CRT (E, Find_Local_Entity (E)); |
19235870 RK |
1503 | end if; |
1504 | ||
5987e59c | 1505 | Front_End_Inlining := False; |
07fc65c4 | 1506 | |
19235870 RK |
1507 | -- Load unit if unit not previously loaded |
1508 | ||
1509 | if No (RE_Table (E)) then | |
fbf5a39b | 1510 | Load_RTU (U_Id, Id => E); |
19235870 RK |
1511 | Lib_Unit := Unit (Cunit (U.Unum)); |
1512 | ||
1513 | -- In the subprogram case, we are all done, the entity we want | |
1514 | -- is the entity for the subprogram itself. Note that we do not | |
1515 | -- bother to check that it is the entity that was requested. | |
1516 | -- the only way that could fail to be the case is if runtime is | |
1517 | -- hopelessly misconfigured, and it isn't worth testing for this. | |
1518 | ||
1519 | if Nkind (Lib_Unit) = N_Subprogram_Declaration then | |
1520 | RE_Table (E) := U.Entity; | |
1521 | ||
fbf5a39b AC |
1522 | -- Otherwise we must have the package case. First check package |
1523 | -- entity itself (e.g. RTE_Name for System.Interrupts.Name) | |
19235870 RK |
1524 | |
1525 | else | |
1526 | pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); | |
1527 | Ename := RE_Chars (E); | |
1528 | ||
d0dd5209 JM |
1529 | -- First we search the package entity chain. If the package |
1530 | -- only has a limited view, scan the corresponding list of | |
1531 | -- incomplete types. | |
1532 | ||
7b56a91b | 1533 | if From_Limited_With (U.Entity) then |
d0dd5209 JM |
1534 | Pkg_Ent := First_Entity (Limited_View (U.Entity)); |
1535 | else | |
1536 | Pkg_Ent := First_Entity (U.Entity); | |
1537 | end if; | |
19235870 | 1538 | |
f937473f RD |
1539 | while Present (Pkg_Ent) loop |
1540 | if Ename = Chars (Pkg_Ent) then | |
1541 | RE_Table (E) := Pkg_Ent; | |
1542 | Check_RPC; | |
1543 | goto Found; | |
1544 | end if; | |
19235870 | 1545 | |
f937473f RD |
1546 | Next_Entity (Pkg_Ent); |
1547 | end loop; | |
0868e09c | 1548 | |
fbf5a39b AC |
1549 | -- If we did not find the entity in the package entity chain, |
1550 | -- then check if the package entity itself matches. Note that | |
1551 | -- we do this check after searching the entity chain, since | |
1552 | -- the rule is that in case of ambiguity, we prefer the entity | |
1553 | -- defined within the package, rather than the package itself. | |
19235870 | 1554 | |
fbf5a39b AC |
1555 | if Ename = Chars (U.Entity) then |
1556 | RE_Table (E) := U.Entity; | |
0868e09c | 1557 | end if; |
fbf5a39b AC |
1558 | |
1559 | -- If we didn't find the entity we want, something is wrong. | |
1560 | -- We just leave RE_Table (E) set to Empty and the appropriate | |
1561 | -- action will be taken by Check_CRT when we exit. | |
1562 | ||
19235870 RK |
1563 | end if; |
1564 | end if; | |
1565 | ||
19235870 | 1566 | <<Found>> |
19235870 | 1567 | |
92219bab PB |
1568 | -- Record whether the secondary stack is in use in order to generate |
1569 | -- the proper binder code. No action is taken when the secondary stack | |
1570 | -- is pulled within an ignored Ghost context because all this code will | |
1571 | -- disappear. | |
1572 | ||
1573 | if U_Id = System_Secondary_Stack and then Ghost_Mode /= Ignore then | |
1574 | Sec_Stack_Used := True; | |
1575 | end if; | |
1576 | ||
1577 | Maybe_Add_With (U); | |
07fc65c4 | 1578 | Front_End_Inlining := Save_Front_End_Inlining; |
92219bab | 1579 | |
f937473f | 1580 | return Check_CRT (E, RE_Table (E)); |
19235870 RK |
1581 | end RTE; |
1582 | ||
fbf5a39b AC |
1583 | ------------------- |
1584 | -- RTE_Available -- | |
1585 | ------------------- | |
1586 | ||
1587 | function RTE_Available (E : RE_Id) return Boolean is | |
1588 | Dummy : Entity_Id; | |
1589 | pragma Warnings (Off, Dummy); | |
1590 | ||
1591 | Result : Boolean; | |
1592 | ||
1593 | Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; | |
1594 | Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; | |
1595 | -- These are saved recursively because the call to load a unit | |
1596 | -- caused by an upper level call may perform a recursive call | |
1597 | -- to this routine during analysis of the corresponding unit. | |
1598 | ||
1599 | begin | |
1600 | RTE_Available_Call := True; | |
1601 | RTE_Is_Available := True; | |
1602 | Dummy := RTE (E); | |
1603 | Result := RTE_Is_Available; | |
1604 | RTE_Available_Call := Save_RTE_Available_Call; | |
1605 | RTE_Is_Available := Save_RTE_Is_Available; | |
1606 | return Result; | |
1607 | ||
1608 | exception | |
1609 | when RE_Not_Available => | |
1610 | RTE_Available_Call := Save_RTE_Available_Call; | |
1611 | RTE_Is_Available := Save_RTE_Is_Available; | |
1612 | return False; | |
1613 | end RTE_Available; | |
1614 | ||
f937473f RD |
1615 | -------------------------- |
1616 | -- RTE_Record_Component -- | |
1617 | -------------------------- | |
1618 | ||
1619 | function RTE_Record_Component (E : RE_Id) return Entity_Id is | |
1620 | U_Id : constant RTU_Id := RE_Unit_Table (E); | |
1621 | U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); | |
1622 | E1 : Entity_Id; | |
1623 | Ename : Name_Id; | |
d0dd5209 | 1624 | Found_E : Entity_Id; |
f937473f RD |
1625 | Lib_Unit : Node_Id; |
1626 | Pkg_Ent : Entity_Id; | |
1627 | ||
1628 | -- The following flag is used to disable front-end inlining when | |
1629 | -- RTE_Record_Component is invoked. This prevents the analysis of other | |
1630 | -- runtime bodies when a particular spec is loaded through Rtsfind. This | |
1631 | -- is both efficient, and it prevents spurious visibility conflicts | |
1632 | -- between use-visible user entities, and entities in run-time packages. | |
1633 | ||
f937473f RD |
1634 | Save_Front_End_Inlining : Boolean; |
1635 | ||
1636 | begin | |
1637 | -- Note: Contrary to subprogram RTE, there is no need to do any special | |
1638 | -- management with package system.ads because it has no record type | |
1639 | -- declarations. | |
1640 | ||
1641 | Save_Front_End_Inlining := Front_End_Inlining; | |
5987e59c | 1642 | Front_End_Inlining := False; |
f937473f RD |
1643 | |
1644 | -- Load unit if unit not previously loaded | |
1645 | ||
1646 | if not Present (U.Entity) then | |
1647 | Load_RTU (U_Id, Id => E); | |
1648 | end if; | |
1649 | ||
1650 | Lib_Unit := Unit (Cunit (U.Unum)); | |
1651 | ||
1652 | pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration); | |
1653 | Ename := RE_Chars (E); | |
1654 | ||
1655 | -- Search the entity in the components of record type declarations | |
1656 | -- found in the package entity chain. | |
1657 | ||
d0dd5209 | 1658 | Found_E := Empty; |
f937473f RD |
1659 | Pkg_Ent := First_Entity (U.Entity); |
1660 | Search : while Present (Pkg_Ent) loop | |
1661 | if Is_Record_Type (Pkg_Ent) then | |
1662 | E1 := First_Entity (Pkg_Ent); | |
1663 | while Present (E1) loop | |
1664 | if Ename = Chars (E1) then | |
d0dd5209 JM |
1665 | pragma Assert (not Present (Found_E)); |
1666 | Found_E := E1; | |
f937473f RD |
1667 | end if; |
1668 | ||
1669 | Next_Entity (E1); | |
1670 | end loop; | |
1671 | end if; | |
1672 | ||
1673 | Next_Entity (Pkg_Ent); | |
1674 | end loop Search; | |
1675 | ||
1676 | -- If we didn't find the entity we want, something is wrong. The | |
1677 | -- appropriate action will be taken by Check_CRT when we exit. | |
1678 | ||
aca53298 | 1679 | Maybe_Add_With (U); |
f937473f RD |
1680 | |
1681 | Front_End_Inlining := Save_Front_End_Inlining; | |
d0dd5209 | 1682 | return Check_CRT (E, Found_E); |
f937473f RD |
1683 | end RTE_Record_Component; |
1684 | ||
1685 | ------------------------------------ | |
1686 | -- RTE_Record_Component_Available -- | |
1687 | ------------------------------------ | |
1688 | ||
1689 | function RTE_Record_Component_Available (E : RE_Id) return Boolean is | |
1690 | Dummy : Entity_Id; | |
1691 | pragma Warnings (Off, Dummy); | |
1692 | ||
1693 | Result : Boolean; | |
1694 | ||
1695 | Save_RTE_Available_Call : constant Boolean := RTE_Available_Call; | |
1696 | Save_RTE_Is_Available : constant Boolean := RTE_Is_Available; | |
1697 | -- These are saved recursively because the call to load a unit | |
1698 | -- caused by an upper level call may perform a recursive call | |
1699 | -- to this routine during analysis of the corresponding unit. | |
1700 | ||
1701 | begin | |
1702 | RTE_Available_Call := True; | |
1703 | RTE_Is_Available := True; | |
1704 | Dummy := RTE_Record_Component (E); | |
1705 | Result := RTE_Is_Available; | |
1706 | RTE_Available_Call := Save_RTE_Available_Call; | |
1707 | RTE_Is_Available := Save_RTE_Is_Available; | |
1708 | return Result; | |
1709 | ||
1710 | exception | |
1711 | when RE_Not_Available => | |
1712 | RTE_Available_Call := Save_RTE_Available_Call; | |
1713 | RTE_Is_Available := Save_RTE_Is_Available; | |
1714 | return False; | |
1715 | end RTE_Record_Component_Available; | |
1716 | ||
fbf5a39b AC |
1717 | ------------------- |
1718 | -- RTE_Error_Msg -- | |
1719 | ------------------- | |
1720 | ||
1721 | procedure RTE_Error_Msg (Msg : String) is | |
1722 | begin | |
1723 | if RTE_Available_Call then | |
1724 | RTE_Is_Available := False; | |
1725 | else | |
1726 | Error_Msg_N (Msg, Current_Error_Node); | |
1727 | ||
1728 | -- Bump count of violations if we are in configurable run-time | |
1729 | -- mode and this is not a continuation message. | |
1730 | ||
1fa4cb20 | 1731 | if Configurable_Run_Time_Mode and then Msg (Msg'First) /= '\' then |
fbf5a39b AC |
1732 | Configurable_Run_Time_Violations := |
1733 | Configurable_Run_Time_Violations + 1; | |
1734 | end if; | |
1735 | end if; | |
1736 | end RTE_Error_Msg; | |
1737 | ||
f937473f RD |
1738 | ---------------- |
1739 | -- RTU_Entity -- | |
1740 | ---------------- | |
1741 | ||
1742 | function RTU_Entity (U : RTU_Id) return Entity_Id is | |
1743 | begin | |
1744 | return RT_Unit_Table (U).Entity; | |
1745 | end RTU_Entity; | |
1746 | ||
9f4fd324 AC |
1747 | ---------------- |
1748 | -- RTU_Loaded -- | |
1749 | ---------------- | |
1750 | ||
1751 | function RTU_Loaded (U : RTU_Id) return Boolean is | |
1752 | begin | |
246d2ceb | 1753 | return Present (RT_Unit_Table (U).Entity); |
9f4fd324 AC |
1754 | end RTU_Loaded; |
1755 | ||
246d2ceb AC |
1756 | -------------------- |
1757 | -- Set_RTU_Loaded -- | |
1758 | -------------------- | |
1759 | ||
1760 | procedure Set_RTU_Loaded (N : Node_Id) is | |
1761 | Loc : constant Source_Ptr := Sloc (N); | |
1762 | Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); | |
1763 | Uname : constant Unit_Name_Type := Unit_Name (Unum); | |
1764 | E : constant Entity_Id := | |
1765 | Defining_Entity (Unit (Cunit (Unum))); | |
1766 | begin | |
8ab31c0c | 1767 | pragma Assert (Is_Predefined_Unit (Unum)); |
246d2ceb AC |
1768 | |
1769 | -- Loop through entries in RTU table looking for matching entry | |
1770 | ||
1771 | for U_Id in RTU_Id'Range loop | |
1772 | ||
1773 | -- Here we have a match | |
1774 | ||
1775 | if Get_Unit_Name (U_Id) = Uname then | |
1776 | declare | |
1777 | U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id); | |
1778 | -- The RT_Unit_Table entry that may need updating | |
1779 | ||
1780 | begin | |
6a497607 AC |
1781 | -- If entry is not set, set it now, and indicate that it was |
1782 | -- loaded through an explicit context clause. | |
246d2ceb | 1783 | |
531eb217 | 1784 | if No (U.Entity) then |
9af094a1 ES |
1785 | U := (Entity => E, |
1786 | Uname => Get_Unit_Name (U_Id), | |
1787 | Unum => Unum, | |
1788 | First_Implicit_With => Empty); | |
246d2ceb AC |
1789 | end if; |
1790 | ||
1791 | return; | |
1792 | end; | |
1793 | end if; | |
1794 | end loop; | |
1795 | end Set_RTU_Loaded; | |
1796 | ||
b912db16 AC |
1797 | ------------------------- |
1798 | -- SPARK_Implicit_Load -- | |
1799 | ------------------------- | |
1800 | ||
1801 | procedure SPARK_Implicit_Load (E : RE_Id) is | |
b912db16 AC |
1802 | begin |
1803 | pragma Assert (GNATprove_Mode); | |
1804 | ||
1805 | -- Force loading of a predefined unit | |
611d5e3c | 1806 | |
13b26a95 | 1807 | Discard_Node (RTE (E)); |
b912db16 AC |
1808 | end SPARK_Implicit_Load; |
1809 | ||
19235870 | 1810 | end Rtsfind; |