1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Exp_Dist
; use Exp_Dist
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Nlists
; use Nlists
;
34 with Nmake
; use Nmake
;
35 with Namet
; use Namet
;
37 with Rtsfind
; use Rtsfind
;
39 with Sem_Res
; use Sem_Res
;
40 with Sem_Util
; use Sem_Util
;
41 with Sinfo
; use Sinfo
;
42 with Snames
; use Snames
;
43 with Stand
; use Stand
;
44 with Stringt
; use Stringt
;
45 with Tbuild
; use Tbuild
;
46 with Uname
; use Uname
;
48 package body Sem_Dist
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 procedure RAS_E_Dereference
(Pref
: Node_Id
);
55 -- Handles explicit dereference of Remote Access to Subprograms.
57 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
58 -- returns the full qualified name of the entity in lower case.
60 -------------------------
61 -- Add_Stub_Constructs --
62 -------------------------
64 procedure Add_Stub_Constructs
(N
: Node_Id
) is
65 U
: constant Node_Id
:= Unit
(N
);
66 Spec
: Entity_Id
:= Empty
;
67 Exp
: Node_Id
:= U
; -- Unit that will be expanded
70 pragma Assert
(Distribution_Stub_Mode
/= No_Stubs
);
72 if Nkind
(U
) = N_Package_Declaration
then
73 Spec
:= Defining_Entity
(Specification
(U
));
75 elsif Nkind
(U
) = N_Package_Body
then
76 Spec
:= Corresponding_Spec
(U
);
78 else pragma Assert
(Nkind
(U
) = N_Package_Instantiation
);
79 Exp
:= Instance_Spec
(U
);
80 Spec
:= Defining_Entity
(Specification
(Exp
));
83 pragma Assert
(Is_Shared_Passive
(Spec
)
84 or else Is_Remote_Call_Interface
(Spec
));
86 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
then
88 if Is_Shared_Passive
(Spec
) then
90 elsif Nkind
(U
) = N_Package_Body
then
92 ("Specification file expected from command line", U
);
94 Expand_Calling_Stubs_Bodies
(Exp
);
99 if Is_Shared_Passive
(Spec
) then
100 Build_Passive_Partition_Stub
(Exp
);
102 Expand_Receiving_Stubs_Bodies
(Exp
);
106 end Add_Stub_Constructs
;
108 -------------------------
109 -- Full_Qualified_Name --
110 -------------------------
112 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
113 Ent
: Entity_Id
:= E
;
114 Parent_Name
: String_Id
:= No_String
;
117 -- Deals properly with child units
119 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
120 Ent
:= Defining_Identifier
(Ent
);
123 -- Compute recursively the qualification. Only "Standard" has no scope.
125 if Present
(Scope
(Scope
(Ent
))) then
126 Parent_Name
:= Full_Qualified_Name
(Scope
(Ent
));
129 -- Every entity should have a name except some expanded blocks
130 -- don't bother about those.
132 if Chars
(Ent
) = No_Name
then
136 -- Add a period between Name and qualification
138 if Parent_Name
/= No_String
then
139 Start_String
(Parent_Name
);
140 Store_String_Char
(Get_Char_Code
('.'));
146 -- Generates the entity name in upper case
148 Get_Name_String
(Chars
(Ent
));
149 Set_Casing
(All_Lower_Case
);
150 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
152 end Full_Qualified_Name
;
154 -----------------------
155 -- Get_Subprogram_Id --
156 -----------------------
158 function Get_Subprogram_Id
(E
: Entity_Id
) return Int
is
159 Current_Declaration
: Node_Id
;
164 (Is_Remote_Call_Interface
(Scope
(E
))
166 (Nkind
(Parent
(E
)) = N_Procedure_Specification
168 Nkind
(Parent
(E
)) = N_Function_Specification
));
170 Current_Declaration
:=
171 First
(Visible_Declarations
172 (Package_Specification_Of_Scope
(Scope
(E
))));
174 while Current_Declaration
/= Empty
loop
175 if Nkind
(Current_Declaration
) = N_Subprogram_Declaration
176 and then Comes_From_Source
(Current_Declaration
)
178 if Defining_Unit_Name
179 (Specification
(Current_Declaration
)) = E
184 Result
:= Result
+ 1;
187 Next
(Current_Declaration
);
190 -- Error if we do not find it
193 end Get_Subprogram_Id
;
195 ------------------------
196 -- Is_All_Remote_Call --
197 ------------------------
199 function Is_All_Remote_Call
(N
: Node_Id
) return Boolean is
203 if (Nkind
(N
) = N_Function_Call
204 or else Nkind
(N
) = N_Procedure_Call_Statement
)
205 and then Nkind
(Name
(N
)) in N_Has_Entity
206 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
207 and then Has_All_Calls_Remote
(Scope
(Entity
(Name
(N
))))
208 and then Comes_From_Source
(N
)
210 Par
:= Parent
(Entity
(Name
(N
)));
213 and then (Nkind
(Par
) /= N_Package_Specification
214 or else Is_Wrapper_Package
(Defining_Entity
(Par
)))
219 if Present
(Par
) then
221 not Scope_Within_Or_Same
(Current_Scope
, Defining_Entity
(Par
));
228 end Is_All_Remote_Call
;
230 ------------------------------------
231 -- Package_Specification_Of_Scope --
232 ------------------------------------
234 function Package_Specification_Of_Scope
(E
: Entity_Id
) return Node_Id
is
235 N
: Node_Id
:= Parent
(E
);
237 while Nkind
(N
) /= N_Package_Specification
loop
242 end Package_Specification_Of_Scope
;
244 --------------------------
245 -- Process_Partition_ID --
246 --------------------------
248 procedure Process_Partition_Id
(N
: Node_Id
) is
249 Loc
: constant Source_Ptr
:= Sloc
(N
);
252 Get_Pt_Id_Call
: Node_Id
;
253 Prefix_String
: String_Id
;
254 Typ
: constant Entity_Id
:= Etype
(N
);
257 Ety
:= Entity
(Prefix
(N
));
259 -- In case prefix is not a library unit entity, get the entity
262 while (Present
(Scope
(Ety
))
263 and then Scope
(Ety
) /= Standard_Standard
)
264 and not Is_Child_Unit
(Ety
)
269 -- Retrieve the proper function to call.
271 if Is_Remote_Call_Interface
(Ety
) then
272 Get_Pt_Id
:= New_Occurrence_Of
273 (RTE
(RE_Get_Active_Partition_Id
), Loc
);
275 elsif Is_Shared_Passive
(Ety
) then
276 Get_Pt_Id
:= New_Occurrence_Of
277 (RTE
(RE_Get_Passive_Partition_Id
), Loc
);
280 Get_Pt_Id
:= New_Occurrence_Of
281 (RTE
(RE_Get_Local_Partition_Id
), Loc
);
284 -- Get and store the String_Id corresponding to the name of the
285 -- library unit whose Partition_Id is needed
287 Get_Unit_Name_String
(Get_Unit_Name
(Unit_Declaration_Node
(Ety
)));
289 -- Remove seven last character ("(spec)" or " (body)").
290 -- (this is a bit nasty, should have interface for this ???)
292 Name_Len
:= Name_Len
- 7;
295 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
296 Prefix_String
:= End_String
;
298 -- Build the function call which will replace the attribute
300 if Is_Remote_Call_Interface
(Ety
)
301 or else Is_Shared_Passive
(Ety
)
304 Make_Function_Call
(Loc
,
306 Parameter_Associations
=>
307 New_List
(Make_String_Literal
(Loc
, Prefix_String
)));
310 Get_Pt_Id_Call
:= Make_Function_Call
(Loc
, Get_Pt_Id
);
314 -- Replace the attribute node by a conversion of the function call
315 -- to the target type.
317 Rewrite
(N
, Convert_To
(Typ
, Get_Pt_Id_Call
));
318 Analyze_And_Resolve
(N
, Typ
);
319 end Process_Partition_Id
;
321 ----------------------------------
322 -- Process_Remote_AST_Attribute --
323 ----------------------------------
325 procedure Process_Remote_AST_Attribute
327 New_Type
: Entity_Id
)
329 Loc
: constant Source_Ptr
:= Sloc
(N
);
330 Remote_Subp
: Entity_Id
;
331 Tick_Access_Conv_Call
: Node_Id
;
332 Remote_Subp_Decl
: Node_Id
;
333 RS_Pkg_Specif
: Node_Id
;
334 RS_Pkg_E
: Entity_Id
;
335 RAS_Type
: Entity_Id
;
338 Attribute_Subp
: Entity_Id
;
342 -- Check if we have to expand the access attribute
344 Remote_Subp
:= Entity
(Prefix
(N
));
346 if not Expander_Active
then
349 elsif Ekind
(New_Type
) = E_Record_Type
then
350 RAS_Type
:= New_Type
;
353 -- If the remote type has not been constructed yet, create
354 -- it and its attributes now.
356 Attribute_Subp
:= TSS
(New_Type
, TSS_RAS_Access
);
358 if No
(Attribute_Subp
) then
359 Add_RAST_Features
(Parent
(New_Type
));
362 RAS_Type
:= Equivalent_Type
(New_Type
);
365 Attribute_Subp
:= TSS
(RAS_Type
, TSS_RAS_Access
);
366 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
368 if Nkind
(Remote_Subp_Decl
) = N_Subprogram_Body
then
369 Remote_Subp
:= Corresponding_Spec
(Remote_Subp_Decl
);
370 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
373 RS_Pkg_Specif
:= Parent
(Remote_Subp_Decl
);
374 RS_Pkg_E
:= Defining_Entity
(RS_Pkg_Specif
);
376 Subp_Id
:= Get_Subprogram_Id
(Remote_Subp
);
378 if Ekind
(Remote_Subp
) = E_Procedure
379 and then Is_Asynchronous
(Remote_Subp
)
381 Async_E
:= Standard_True
;
383 Async_E
:= Standard_False
;
386 Parameter
:= New_Occurrence_Of
(RTE
(RE_Null_Address
), Loc
);
388 Tick_Access_Conv_Call
:=
389 Make_Function_Call
(Loc
,
390 Name
=> New_Occurrence_Of
(Attribute_Subp
, Loc
),
391 Parameter_Associations
=>
394 Make_String_Literal
(Loc
, Full_Qualified_Name
(RS_Pkg_E
)),
395 Make_Integer_Literal
(Loc
, Subp_Id
),
396 New_Occurrence_Of
(Async_E
, Loc
)));
398 Rewrite
(N
, Tick_Access_Conv_Call
);
399 Analyze_And_Resolve
(N
, RAS_Type
);
400 end Process_Remote_AST_Attribute
;
402 ------------------------------------
403 -- Process_Remote_AST_Declaration --
404 ------------------------------------
406 procedure Process_Remote_AST_Declaration
(N
: Node_Id
) is
407 Loc
: constant Source_Ptr
:= Sloc
(N
);
408 User_Type
: constant Node_Id
:= Defining_Identifier
(N
);
409 Fat_Type
: constant Entity_Id
:=
410 Make_Defining_Identifier
411 (Loc
, Chars
(User_Type
));
412 New_Type_Decl
: Node_Id
;
415 -- We add a record type declaration for the equivalent fat pointer type
418 Make_Full_Type_Declaration
(Loc
,
419 Defining_Identifier
=> Fat_Type
,
421 Make_Record_Definition
(Loc
,
423 Make_Component_List
(Loc
,
424 Component_Items
=> New_List
(
426 Make_Component_Declaration
(Loc
,
427 Defining_Identifier
=>
428 Make_Defining_Identifier
(Loc
,
430 Subtype_Indication
=>
432 (RTE
(RE_Unsigned_64
), Loc
)),
434 Make_Component_Declaration
(Loc
,
435 Defining_Identifier
=>
436 Make_Defining_Identifier
(Loc
,
437 Chars
=> Name_Origin
),
438 Subtype_Indication
=>
443 Make_Component_Declaration
(Loc
,
444 Defining_Identifier
=>
445 Make_Defining_Identifier
(Loc
,
446 Chars
=> Name_Receiver
),
447 Subtype_Indication
=>
449 (RTE
(RE_Unsigned_64
), Loc
)),
451 Make_Component_Declaration
(Loc
,
452 Defining_Identifier
=>
453 Make_Defining_Identifier
(Loc
,
454 Chars
=> Name_Subp_Id
),
455 Subtype_Indication
=>
460 Make_Component_Declaration
(Loc
,
461 Defining_Identifier
=>
462 Make_Defining_Identifier
(Loc
,
463 Chars
=> Name_Async
),
464 Subtype_Indication
=>
469 Insert_After
(N
, New_Type_Decl
);
470 Set_Equivalent_Type
(User_Type
, Fat_Type
);
471 Set_Corresponding_Remote_Type
(Fat_Type
, User_Type
);
473 -- The reason we suppress the initialization procedure is that we know
474 -- that no initialization is required (even if Initialize_Scalars mode
475 -- is active), and there are order of elaboration problems if we do try
476 -- to generate an init proc for this created record type.
478 Set_Suppress_Init_Proc
(Fat_Type
);
480 if Expander_Active
then
481 Add_RAST_Features
(Parent
(User_Type
));
483 end Process_Remote_AST_Declaration
;
485 -----------------------
486 -- RAS_E_Dereference --
487 -----------------------
489 procedure RAS_E_Dereference
(Pref
: Node_Id
) is
490 Loc
: constant Source_Ptr
:= Sloc
(Pref
);
492 New_Type
: constant Entity_Id
:= Etype
(Pref
);
493 RAS
: constant Entity_Id
:=
494 Corresponding_Remote_Type
(New_Type
);
495 RAS_Decl
: constant Node_Id
:= Parent
(RAS
);
496 Explicit_Deref
: constant Node_Id
:= Parent
(Pref
);
497 Deref_Subp_Call
: constant Node_Id
:= Parent
(Explicit_Deref
);
498 Deref_Proc
: Entity_Id
;
502 if Nkind
(Deref_Subp_Call
) = N_Procedure_Call_Statement
then
503 Params
:= Parameter_Associations
(Deref_Subp_Call
);
505 if Present
(Params
) then
506 Prepend
(Pref
, Params
);
508 Params
:= New_List
(Pref
);
511 elsif Nkind
(Deref_Subp_Call
) = N_Indexed_Component
then
513 Params
:= Expressions
(Deref_Subp_Call
);
515 if Present
(Params
) then
516 Prepend
(Pref
, Params
);
518 Params
:= New_List
(Pref
);
522 -- Context is not a call.
527 Deref_Proc
:= TSS
(New_Type
, TSS_RAS_Dereference
);
529 if not Expander_Active
then
532 elsif No
(Deref_Proc
) then
533 Add_RAST_Features
(RAS_Decl
);
534 Deref_Proc
:= TSS
(New_Type
, TSS_RAS_Dereference
);
537 if Ekind
(Deref_Proc
) = E_Function
then
539 Make_Function_Call
(Loc
,
540 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
541 Parameter_Associations
=> Params
);
545 Make_Procedure_Call_Statement
(Loc
,
546 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
547 Parameter_Associations
=> Params
);
550 Rewrite
(Deref_Subp_Call
, Call_Node
);
551 Analyze
(Deref_Subp_Call
);
552 end RAS_E_Dereference
;
554 ------------------------------
555 -- Remote_AST_E_Dereference --
556 ------------------------------
558 function Remote_AST_E_Dereference
(P
: Node_Id
) return Boolean
560 ET
: constant Entity_Id
:= Etype
(P
);
563 -- Perform the changes only on original dereferences, and only if
564 -- we are generating code.
566 if Comes_From_Source
(P
)
567 and then Is_Record_Type
(ET
)
568 and then (Is_Remote_Call_Interface
(ET
)
569 or else Is_Remote_Types
(ET
))
570 and then Present
(Corresponding_Remote_Type
(ET
))
571 and then (Nkind
(Parent
(Parent
(P
))) = N_Procedure_Call_Statement
572 or else Nkind
(Parent
(Parent
(P
))) = N_Indexed_Component
)
573 and then Expander_Active
575 RAS_E_Dereference
(P
);
580 end Remote_AST_E_Dereference
;
582 ------------------------------
583 -- Remote_AST_I_Dereference --
584 ------------------------------
586 function Remote_AST_I_Dereference
(P
: Node_Id
) return Boolean
588 ET
: constant Entity_Id
:= Etype
(P
);
592 if Comes_From_Source
(P
)
593 and then (Is_Remote_Call_Interface
(ET
)
594 or else Is_Remote_Types
(ET
))
595 and then Present
(Corresponding_Remote_Type
(ET
))
596 and then Ekind
(Entity
(P
)) /= E_Function
599 Make_Explicit_Dereference
(Sloc
(P
),
600 Prefix
=> Relocate_Node
(P
));
603 RAS_E_Dereference
(Prefix
(P
));
608 end Remote_AST_I_Dereference
;
610 ---------------------------
611 -- Remote_AST_Null_Value --
612 ---------------------------
614 function Remote_AST_Null_Value
619 Loc
: constant Source_Ptr
:= Sloc
(N
);
620 Target_Type
: Entity_Id
;
623 if not Expander_Active
then
626 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
627 and then (Is_Remote_Call_Interface
(Typ
)
628 or else Is_Remote_Types
(Typ
))
629 and then Comes_From_Source
(N
)
630 and then Expander_Active
632 -- Any null that comes from source and is of the RAS type must
633 -- be expanded, except if expansion is not active (nothing
634 -- gets expanded into the equivalent record type).
636 Target_Type
:= Equivalent_Type
(Typ
);
638 elsif Ekind
(Typ
) = E_Record_Type
639 and then Present
(Corresponding_Remote_Type
(Typ
))
641 -- This is a record type representing a RAS type, this must be
647 -- We do not have to handle this case
655 Expressions
=> New_List
(
656 Make_Integer_Literal
(Loc
, 0), -- Ras
657 Make_Integer_Literal
(Loc
, 0), -- Origin
658 Make_Integer_Literal
(Loc
, 0), -- Receiver
659 Make_Integer_Literal
(Loc
, 0), -- Subp_Id
660 New_Occurrence_Of
(Standard_False
, Loc
)))); -- Asyn
661 Analyze_And_Resolve
(N
, Target_Type
);
663 end Remote_AST_Null_Value
;