1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004, 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
;
47 package body Sem_Dist
is
49 -----------------------
50 -- Local Subprograms --
51 -----------------------
53 procedure RAS_E_Dereference
(Pref
: Node_Id
);
54 -- Handles explicit dereference of Remote Access to Subprograms.
56 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
57 -- returns the full qualified name of the entity in lower case.
59 -------------------------
60 -- Add_Stub_Constructs --
61 -------------------------
63 procedure Add_Stub_Constructs
(N
: Node_Id
) is
64 U
: constant Node_Id
:= Unit
(N
);
65 Spec
: Entity_Id
:= Empty
;
66 Exp
: Node_Id
:= U
; -- Unit that will be expanded
69 pragma Assert
(Distribution_Stub_Mode
/= No_Stubs
);
71 if Nkind
(U
) = N_Package_Declaration
then
72 Spec
:= Defining_Entity
(Specification
(U
));
74 elsif Nkind
(U
) = N_Package_Body
then
75 Spec
:= Corresponding_Spec
(U
);
77 else pragma Assert
(Nkind
(U
) = N_Package_Instantiation
);
78 Exp
:= Instance_Spec
(U
);
79 Spec
:= Defining_Entity
(Specification
(Exp
));
82 pragma Assert
(Is_Shared_Passive
(Spec
)
83 or else Is_Remote_Call_Interface
(Spec
));
85 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
then
87 if Is_Shared_Passive
(Spec
) then
89 elsif Nkind
(U
) = N_Package_Body
then
91 ("Specification file expected from command line", U
);
93 Expand_Calling_Stubs_Bodies
(Exp
);
98 if Is_Shared_Passive
(Spec
) then
99 Build_Passive_Partition_Stub
(Exp
);
101 Expand_Receiving_Stubs_Bodies
(Exp
);
105 end Add_Stub_Constructs
;
107 ---------------------------------------
108 -- Build_RAS_Primitive_Specification --
109 ---------------------------------------
111 function Build_RAS_Primitive_Specification
112 (Subp_Spec
: Node_Id
;
113 Remote_Object_Type
: Node_Id
) return Node_Id
115 Loc
: constant Source_Ptr
:= Sloc
(Subp_Spec
);
117 Primitive_Spec
: constant Node_Id
:=
118 Copy_Specification
(Loc
,
120 New_Name
=> Name_Call
);
122 Subtype_Mark_For_Self
: Node_Id
;
125 if No
(Parameter_Specifications
(Primitive_Spec
)) then
126 Set_Parameter_Specifications
(Primitive_Spec
, New_List
);
129 if Nkind
(Remote_Object_Type
) in N_Entity
then
130 Subtype_Mark_For_Self
:=
131 New_Occurrence_Of
(Remote_Object_Type
, Loc
);
133 Subtype_Mark_For_Self
:= Remote_Object_Type
;
137 Parameter_Specifications
(Primitive_Spec
),
138 Make_Parameter_Specification
(Loc
,
139 Defining_Identifier
=>
140 Make_Defining_Identifier
(Loc
, Name_uS
),
142 Make_Access_Definition
(Loc
,
144 Subtype_Mark_For_Self
)));
146 -- Trick later semantic analysis into considering this
147 -- operation as a primitive (dispatching) operation of
148 -- tagged type Obj_Type.
150 Set_Comes_From_Source
(
151 Defining_Unit_Name
(Primitive_Spec
), True);
153 return Primitive_Spec
;
154 end Build_RAS_Primitive_Specification
;
156 -------------------------
157 -- Full_Qualified_Name --
158 -------------------------
160 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
161 Ent
: Entity_Id
:= E
;
162 Parent_Name
: String_Id
:= No_String
;
165 -- Deals properly with child units
167 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
168 Ent
:= Defining_Identifier
(Ent
);
171 -- Compute recursively the qualification. Only "Standard" has no scope.
173 if Present
(Scope
(Scope
(Ent
))) then
174 Parent_Name
:= Full_Qualified_Name
(Scope
(Ent
));
177 -- Every entity should have a name except some expanded blocks
178 -- don't bother about those.
180 if Chars
(Ent
) = No_Name
then
184 -- Add a period between Name and qualification
186 if Parent_Name
/= No_String
then
187 Start_String
(Parent_Name
);
188 Store_String_Char
(Get_Char_Code
('.'));
194 -- Generates the entity name in upper case
196 Get_Name_String
(Chars
(Ent
));
197 Set_Casing
(All_Lower_Case
);
198 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
200 end Full_Qualified_Name
;
202 ------------------------
203 -- Is_All_Remote_Call --
204 ------------------------
206 function Is_All_Remote_Call
(N
: Node_Id
) return Boolean is
210 if (Nkind
(N
) = N_Function_Call
211 or else Nkind
(N
) = N_Procedure_Call_Statement
)
212 and then Nkind
(Name
(N
)) in N_Has_Entity
213 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
214 and then Has_All_Calls_Remote
(Scope
(Entity
(Name
(N
))))
215 and then Comes_From_Source
(N
)
217 Par
:= Parent
(Entity
(Name
(N
)));
220 and then (Nkind
(Par
) /= N_Package_Specification
221 or else Is_Wrapper_Package
(Defining_Entity
(Par
)))
226 if Present
(Par
) then
228 not Scope_Within_Or_Same
(Current_Scope
, Defining_Entity
(Par
));
235 end Is_All_Remote_Call
;
237 ------------------------------------
238 -- Package_Specification_Of_Scope --
239 ------------------------------------
241 function Package_Specification_Of_Scope
(E
: Entity_Id
) return Node_Id
is
242 N
: Node_Id
:= Parent
(E
);
244 while Nkind
(N
) /= N_Package_Specification
loop
249 end Package_Specification_Of_Scope
;
251 --------------------------
252 -- Process_Partition_ID --
253 --------------------------
255 procedure Process_Partition_Id
(N
: Node_Id
) is
256 Loc
: constant Source_Ptr
:= Sloc
(N
);
259 Get_Pt_Id_Call
: Node_Id
;
260 Prefix_String
: String_Id
;
261 Typ
: constant Entity_Id
:= Etype
(N
);
264 Ety
:= Entity
(Prefix
(N
));
266 -- In case prefix is not a library unit entity, get the entity
269 while (Present
(Scope
(Ety
))
270 and then Scope
(Ety
) /= Standard_Standard
)
271 and not Is_Child_Unit
(Ety
)
276 -- Retrieve the proper function to call.
278 if Is_Remote_Call_Interface
(Ety
) then
279 Get_Pt_Id
:= New_Occurrence_Of
280 (RTE
(RE_Get_Active_Partition_Id
), Loc
);
282 elsif Is_Shared_Passive
(Ety
) then
283 Get_Pt_Id
:= New_Occurrence_Of
284 (RTE
(RE_Get_Passive_Partition_Id
), Loc
);
287 Get_Pt_Id
:= New_Occurrence_Of
288 (RTE
(RE_Get_Local_Partition_Id
), Loc
);
291 -- Get and store the String_Id corresponding to the name of the
292 -- library unit whose Partition_Id is needed.
294 Get_Library_Unit_Name_String
(Unit_Declaration_Node
(Ety
));
295 Prefix_String
:= String_From_Name_Buffer
;
297 -- Build the function call which will replace the attribute
299 if Is_Remote_Call_Interface
(Ety
)
300 or else Is_Shared_Passive
(Ety
)
303 Make_Function_Call
(Loc
,
305 Parameter_Associations
=>
306 New_List
(Make_String_Literal
(Loc
, Prefix_String
)));
309 Get_Pt_Id_Call
:= Make_Function_Call
(Loc
, Get_Pt_Id
);
313 -- Replace the attribute node by a conversion of the function call
314 -- to the target type.
316 Rewrite
(N
, Convert_To
(Typ
, Get_Pt_Id_Call
));
317 Analyze_And_Resolve
(N
, Typ
);
318 end Process_Partition_Id
;
320 ----------------------------------
321 -- Process_Remote_AST_Attribute --
322 ----------------------------------
324 procedure Process_Remote_AST_Attribute
326 New_Type
: Entity_Id
)
328 Loc
: constant Source_Ptr
:= Sloc
(N
);
329 Remote_Subp
: Entity_Id
;
330 Tick_Access_Conv_Call
: Node_Id
;
331 Remote_Subp_Decl
: Node_Id
;
332 RS_Pkg_Specif
: Node_Id
;
333 RS_Pkg_E
: Entity_Id
;
334 RAS_Type
: Entity_Id
:= New_Type
;
336 All_Calls_Remote_E
: Entity_Id
;
337 Attribute_Subp
: Entity_Id
;
340 -- Check if we have to expand the access attribute
342 Remote_Subp
:= Entity
(Prefix
(N
));
344 if not Expander_Active
then
348 if Ekind
(RAS_Type
) /= E_Record_Type
then
349 RAS_Type
:= Equivalent_Type
(RAS_Type
);
352 Attribute_Subp
:= TSS
(RAS_Type
, TSS_RAS_Access
);
353 pragma Assert
(Present
(Attribute_Subp
));
354 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
356 if Nkind
(Remote_Subp_Decl
) = N_Subprogram_Body
then
357 Remote_Subp
:= Corresponding_Spec
(Remote_Subp_Decl
);
358 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
361 RS_Pkg_Specif
:= Parent
(Remote_Subp_Decl
);
362 RS_Pkg_E
:= Defining_Entity
(RS_Pkg_Specif
);
365 Boolean_Literals
(Ekind
(Remote_Subp
) = E_Procedure
366 and then Is_Asynchronous
(Remote_Subp
));
368 All_Calls_Remote_E
:=
369 Boolean_Literals
(Has_All_Calls_Remote
(RS_Pkg_E
));
371 Tick_Access_Conv_Call
:=
372 Make_Function_Call
(Loc
,
373 Name
=> New_Occurrence_Of
(Attribute_Subp
, Loc
),
374 Parameter_Associations
=>
376 Make_String_Literal
(Loc
, Full_Qualified_Name
(RS_Pkg_E
)),
377 Build_Subprogram_Id
(Loc
, Remote_Subp
),
378 New_Occurrence_Of
(Async_E
, Loc
),
379 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
)));
381 Rewrite
(N
, Tick_Access_Conv_Call
);
382 Analyze_And_Resolve
(N
, RAS_Type
);
383 end Process_Remote_AST_Attribute
;
385 ------------------------------------
386 -- Process_Remote_AST_Declaration --
387 ------------------------------------
389 procedure Process_Remote_AST_Declaration
(N
: Node_Id
) is
390 Loc
: constant Source_Ptr
:= Sloc
(N
);
391 User_Type
: constant Node_Id
:= Defining_Identifier
(N
);
392 Scop
: constant Entity_Id
:= Scope
(User_Type
);
393 Is_RCI
: constant Boolean :=
394 Is_Remote_Call_Interface
(Scop
);
395 Is_RT
: constant Boolean :=
396 Is_Remote_Types
(Scop
);
397 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
400 Is_Degenerate
: Boolean;
401 -- True iff this RAS has an access formal parameter (see
402 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
404 Subpkg
: constant Entity_Id
:=
405 Make_Defining_Identifier
406 (Loc
, New_Internal_Name
('S'));
407 Subpkg_Decl
: Node_Id
;
408 Vis_Decls
: constant List_Id
:= New_List
;
409 Priv_Decls
: constant List_Id
:= New_List
;
411 Obj_Type
: constant Entity_Id
:=
412 Make_Defining_Identifier
413 (Loc
, New_External_Name
(
414 Chars
(User_Type
), 'R'));
417 Full_Obj_Type
: constant Entity_Id
:=
418 Make_Defining_Identifier
419 (Loc
, Chars
(Obj_Type
));
421 RACW_Type
: constant Entity_Id
:=
422 Make_Defining_Identifier
423 (Loc
, New_External_Name
(
424 Chars
(User_Type
), 'P'));
426 Fat_Type
: constant Entity_Id
:=
427 Make_Defining_Identifier
428 (Loc
, Chars
(User_Type
));
429 Fat_Type_Decl
: Node_Id
;
433 -- The tagged private type, primitive operation and RACW
434 -- type associated with a RAS need to all be declared in
435 -- a subpackage of the one that contains the RAS declaration,
436 -- because the primitive of the object type, and the associated
437 -- primitive of the stub type, need to be dispatching operations
438 -- of these types, and the profile of the RAS might contain
439 -- tagged types declared in the same scope.
441 Append_To
(Vis_Decls
,
442 Make_Private_Type_Declaration
(Loc
,
443 Defining_Identifier
=> Obj_Type
,
444 Abstract_Present
=> True,
445 Tagged_Present
=> True,
446 Limited_Present
=> True));
448 Append_To
(Priv_Decls
,
449 Make_Full_Type_Declaration
(Loc
,
450 Defining_Identifier
=>
453 Make_Record_Definition
(Loc
,
454 Abstract_Present
=> True,
455 Tagged_Present
=> True,
456 Limited_Present
=> True,
457 Null_Present
=> True,
458 Component_List
=> Empty
)));
460 Is_Degenerate
:= False;
461 Parameter
:= First
(Parameter_Specifications
(Type_Def
));
462 Parameters
: while Present
(Parameter
) loop
463 if Nkind
(Parameter_Type
(Parameter
)) = N_Access_Definition
then
464 Error_Msg_N
("formal parameter& has anonymous access type?",
465 Defining_Identifier
(Parameter
));
466 Is_Degenerate
:= True;
472 if Is_Degenerate
then
474 "remote access-to-subprogram type& can only be null?",
475 Defining_Identifier
(Parameter
), User_Type
);
476 -- The only legal value for a RAS with a formal parameter of an
477 -- anonymous access type is null, because it cannot be
478 -- subtype-Conformant with any legal remote subprogram declaration.
479 -- In this case, we cannot generate a corresponding primitive
483 Append_To
(Vis_Decls
,
484 Make_Abstract_Subprogram_Declaration
(Loc
,
485 Specification
=> Build_RAS_Primitive_Specification
(
486 Subp_Spec
=> Type_Def
,
487 Remote_Object_Type
=> Obj_Type
)));
490 Append_To
(Vis_Decls
,
491 Make_Full_Type_Declaration
(Loc
,
492 Defining_Identifier
=> RACW_Type
,
494 Make_Access_To_Object_Definition
(Loc
,
496 Subtype_Indication
=>
497 Make_Attribute_Reference
(Loc
,
499 New_Occurrence_Of
(Obj_Type
, Loc
),
502 Set_Is_Remote_Call_Interface
(RACW_Type
, Is_RCI
);
503 Set_Is_Remote_Types
(RACW_Type
, Is_RT
);
506 Make_Package_Declaration
(Loc
,
507 Make_Package_Specification
(Loc
,
508 Defining_Unit_Name
=>
510 Visible_Declarations
=>
512 Private_Declarations
=>
515 New_Occurrence_Of
(Subpkg
, Loc
)));
516 Set_Is_Remote_Call_Interface
(Subpkg
, Is_RCI
);
517 Set_Is_Remote_Types
(Subpkg
, Is_RT
);
518 Insert_After_And_Analyze
(N
, Subpkg_Decl
);
520 -- Many parts of the analyzer and expander expect
521 -- that the fat pointer type used to implement remote
522 -- access to subprogram types be a record.
523 -- Note: The structure of this type must be kept consistent
524 -- with the code generated by Remote_AST_Null_Value for the
525 -- corresponding 'null' expression.
527 Fat_Type_Decl
:= Make_Full_Type_Declaration
(Loc
,
528 Defining_Identifier
=> Fat_Type
,
530 Make_Record_Definition
(Loc
,
532 Make_Component_List
(Loc
,
533 Component_Items
=> New_List
(
534 Make_Component_Declaration
(Loc
,
535 Defining_Identifier
=>
536 Make_Defining_Identifier
(Loc
, Name_Ras
),
537 Component_Definition
=>
538 Make_Component_Definition
(Loc
,
541 Subtype_Indication
=>
542 New_Occurrence_Of
(RACW_Type
, Loc
)))))));
543 Set_Equivalent_Type
(User_Type
, Fat_Type
);
544 Set_Corresponding_Remote_Type
(Fat_Type
, User_Type
);
545 Insert_After_And_Analyze
(Subpkg_Decl
, Fat_Type_Decl
);
547 -- The reason we suppress the initialization procedure is that we know
548 -- that no initialization is required (even if Initialize_Scalars mode
549 -- is active), and there are order of elaboration problems if we do try
550 -- to generate an init proc for this created record type.
552 Set_Suppress_Init_Proc
(Fat_Type
);
554 if Expander_Active
then
555 Add_RAST_Features
(Parent
(User_Type
));
557 end Process_Remote_AST_Declaration
;
559 -----------------------
560 -- RAS_E_Dereference --
561 -----------------------
563 procedure RAS_E_Dereference
(Pref
: Node_Id
) is
564 Loc
: constant Source_Ptr
:= Sloc
(Pref
);
566 New_Type
: constant Entity_Id
:= Etype
(Pref
);
567 Explicit_Deref
: constant Node_Id
:= Parent
(Pref
);
568 Deref_Subp_Call
: constant Node_Id
:= Parent
(Explicit_Deref
);
569 Deref_Proc
: Entity_Id
;
573 if Nkind
(Deref_Subp_Call
) = N_Procedure_Call_Statement
then
574 Params
:= Parameter_Associations
(Deref_Subp_Call
);
576 if Present
(Params
) then
577 Prepend
(Pref
, Params
);
579 Params
:= New_List
(Pref
);
582 elsif Nkind
(Deref_Subp_Call
) = N_Indexed_Component
then
584 Params
:= Expressions
(Deref_Subp_Call
);
586 if Present
(Params
) then
587 Prepend
(Pref
, Params
);
589 Params
:= New_List
(Pref
);
593 -- Context is not a call.
598 if not Expander_Active
then
602 Deref_Proc
:= TSS
(New_Type
, TSS_RAS_Dereference
);
603 pragma Assert
(Present
(Deref_Proc
));
605 if Ekind
(Deref_Proc
) = E_Function
then
607 Make_Function_Call
(Loc
,
608 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
609 Parameter_Associations
=> Params
);
613 Make_Procedure_Call_Statement
(Loc
,
614 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
615 Parameter_Associations
=> Params
);
618 Rewrite
(Deref_Subp_Call
, Call_Node
);
619 Analyze
(Deref_Subp_Call
);
620 end RAS_E_Dereference
;
622 ------------------------------
623 -- Remote_AST_E_Dereference --
624 ------------------------------
626 function Remote_AST_E_Dereference
(P
: Node_Id
) return Boolean is
627 ET
: constant Entity_Id
:= Etype
(P
);
630 -- Perform the changes only on original dereferences, and only if
631 -- we are generating code.
633 if Comes_From_Source
(P
)
634 and then Is_Record_Type
(ET
)
635 and then (Is_Remote_Call_Interface
(ET
)
636 or else Is_Remote_Types
(ET
))
637 and then Present
(Corresponding_Remote_Type
(ET
))
638 and then (Nkind
(Parent
(Parent
(P
))) = N_Procedure_Call_Statement
639 or else Nkind
(Parent
(Parent
(P
))) = N_Indexed_Component
)
640 and then Expander_Active
642 RAS_E_Dereference
(P
);
647 end Remote_AST_E_Dereference
;
649 ------------------------------
650 -- Remote_AST_I_Dereference --
651 ------------------------------
653 function Remote_AST_I_Dereference
(P
: Node_Id
) return Boolean is
654 ET
: constant Entity_Id
:= Etype
(P
);
658 if Comes_From_Source
(P
)
659 and then (Is_Remote_Call_Interface
(ET
)
660 or else Is_Remote_Types
(ET
))
661 and then Present
(Corresponding_Remote_Type
(ET
))
662 and then Ekind
(Entity
(P
)) /= E_Function
665 Make_Explicit_Dereference
(Sloc
(P
),
666 Prefix
=> Relocate_Node
(P
));
669 RAS_E_Dereference
(Prefix
(P
));
674 end Remote_AST_I_Dereference
;
676 ---------------------------
677 -- Remote_AST_Null_Value --
678 ---------------------------
680 function Remote_AST_Null_Value
682 Typ
: Entity_Id
) return Boolean
684 Loc
: constant Source_Ptr
:= Sloc
(N
);
685 Target_Type
: Entity_Id
;
688 if not Expander_Active
then
691 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
692 and then (Is_Remote_Call_Interface
(Typ
)
693 or else Is_Remote_Types
(Typ
))
694 and then Comes_From_Source
(N
)
695 and then Expander_Active
697 -- Any null that comes from source and is of the RAS type must
698 -- be expanded, except if expansion is not active (nothing
699 -- gets expanded into the equivalent record type).
701 Target_Type
:= Equivalent_Type
(Typ
);
703 elsif Ekind
(Typ
) = E_Record_Type
704 and then Present
(Corresponding_Remote_Type
(Typ
))
706 -- This is a record type representing a RAS type, this must be
712 -- We do not have to handle this case
720 Component_Associations
=> New_List
(
721 Make_Component_Association
(Loc
,
722 Choices
=> New_List
(
723 Make_Identifier
(Loc
, Name_Ras
)),
726 Analyze_And_Resolve
(N
, Target_Type
);
728 end Remote_AST_Null_Value
;