1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Exp_Dist
; use Exp_Dist
;
31 with Exp_Tss
; use Exp_Tss
;
32 with Nlists
; use Nlists
;
33 with Nmake
; use Nmake
;
34 with Namet
; use Namet
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Disp
; use Sem_Disp
;
40 with Sem_Eval
; use Sem_Eval
;
41 with Sem_Res
; use Sem_Res
;
42 with Sem_Util
; use Sem_Util
;
43 with Sinfo
; use Sinfo
;
44 with Stand
; use Stand
;
45 with Stringt
; use Stringt
;
46 with Tbuild
; use Tbuild
;
47 with Uintp
; use Uintp
;
49 package body Sem_Dist
is
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 procedure RAS_E_Dereference
(Pref
: Node_Id
);
56 -- Handles explicit dereference of Remote Access to Subprograms
58 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
59 -- returns the full qualified name of the entity in lower case
61 -------------------------
62 -- Add_Stub_Constructs --
63 -------------------------
65 procedure Add_Stub_Constructs
(N
: Node_Id
) is
66 U
: constant Node_Id
:= Unit
(N
);
67 Spec
: Entity_Id
:= Empty
;
70 -- Unit that will be expanded
73 pragma Assert
(Distribution_Stub_Mode
/= No_Stubs
);
75 if Nkind
(U
) = N_Package_Declaration
then
76 Spec
:= Defining_Entity
(Specification
(U
));
78 elsif Nkind
(U
) = N_Package_Body
then
79 Spec
:= Corresponding_Spec
(U
);
81 else pragma Assert
(Nkind
(U
) = N_Package_Instantiation
);
82 Exp
:= Instance_Spec
(U
);
83 Spec
:= Defining_Entity
(Specification
(Exp
));
86 pragma Assert
(Is_Shared_Passive
(Spec
)
87 or else Is_Remote_Call_Interface
(Spec
));
89 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
then
90 if Is_Shared_Passive
(Spec
) then
92 elsif Nkind
(U
) = N_Package_Body
then
94 ("Specification file expected from command line", U
);
96 Expand_Calling_Stubs_Bodies
(Exp
);
100 if Is_Shared_Passive
(Spec
) then
101 Build_Passive_Partition_Stub
(Exp
);
103 Expand_Receiving_Stubs_Bodies
(Exp
);
107 end Add_Stub_Constructs
;
109 ---------------------------------------
110 -- Build_RAS_Primitive_Specification --
111 ---------------------------------------
113 function Build_RAS_Primitive_Specification
114 (Subp_Spec
: Node_Id
;
115 Remote_Object_Type
: Node_Id
) return Node_Id
117 Loc
: constant Source_Ptr
:= Sloc
(Subp_Spec
);
119 Primitive_Spec
: constant Node_Id
:=
120 Copy_Specification
(Loc
,
122 New_Name
=> Name_uCall
);
124 Subtype_Mark_For_Self
: Node_Id
;
127 if No
(Parameter_Specifications
(Primitive_Spec
)) then
128 Set_Parameter_Specifications
(Primitive_Spec
, New_List
);
131 if Nkind
(Remote_Object_Type
) in N_Entity
then
132 Subtype_Mark_For_Self
:=
133 New_Occurrence_Of
(Remote_Object_Type
, Loc
);
135 Subtype_Mark_For_Self
:= Remote_Object_Type
;
139 Parameter_Specifications
(Primitive_Spec
),
140 Make_Parameter_Specification
(Loc
,
141 Defining_Identifier
=>
142 Make_Defining_Identifier
(Loc
, Name_uS
),
144 Make_Access_Definition
(Loc
,
146 Subtype_Mark_For_Self
)));
148 -- Trick later semantic analysis into considering this operation as a
149 -- primitive (dispatching) operation of tagged type Obj_Type.
151 Set_Comes_From_Source
(
152 Defining_Unit_Name
(Primitive_Spec
), True);
154 return Primitive_Spec
;
155 end Build_RAS_Primitive_Specification
;
157 -------------------------
158 -- Full_Qualified_Name --
159 -------------------------
161 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
162 Ent
: Entity_Id
:= E
;
163 Parent_Name
: String_Id
:= No_String
;
166 -- Deals properly with child units
168 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
169 Ent
:= Defining_Identifier
(Ent
);
172 -- Compute recursively the qualification (only "Standard" has no scope)
174 if Present
(Scope
(Scope
(Ent
))) then
175 Parent_Name
:= Full_Qualified_Name
(Scope
(Ent
));
178 -- Every entity should have a name except some expanded blocks. Do not
179 -- bother about those.
181 if Chars
(Ent
) = No_Name
then
185 -- Add a period between Name and qualification
187 if Parent_Name
/= No_String
then
188 Start_String
(Parent_Name
);
189 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
;
206 function Get_PCS_Name
return PCS_Names
is
209 Chars
(Entity
(Expression
(Parent
(RTE
(RE_DSA_Implementation
)))));
212 ---------------------
213 -- Get_PCS_Version --
214 ---------------------
216 function Get_PCS_Version
return Int
is
217 PCS_Version_Entity
: Entity_Id
;
221 if RTE_Available
(RE_PCS_Version
) then
222 PCS_Version_Entity
:= RTE
(RE_PCS_Version
);
223 pragma Assert
(Ekind
(PCS_Version_Entity
) = E_Named_Integer
);
225 UI_To_Int
(Expr_Value
(Constant_Value
(PCS_Version_Entity
)));
228 -- Case of System.Partition_Interface.PCS_Version not found:
229 -- return a null version.
237 ------------------------
238 -- Is_All_Remote_Call --
239 ------------------------
241 function Is_All_Remote_Call
(N
: Node_Id
) return Boolean is
245 if Nkind
(N
) in N_Subprogram_Call
246 and then Nkind
(Name
(N
)) in N_Has_Entity
247 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
248 and then Has_All_Calls_Remote
(Scope
(Entity
(Name
(N
))))
249 and then Comes_From_Source
(N
)
251 Par
:= Parent
(Entity
(Name
(N
)));
253 and then (Nkind
(Par
) /= N_Package_Specification
254 or else Is_Wrapper_Package
(Defining_Entity
(Par
)))
259 if Present
(Par
) then
261 not Scope_Within_Or_Same
(Current_Scope
, Defining_Entity
(Par
));
268 end Is_All_Remote_Call
;
270 ---------------------------------
271 -- Is_RACW_Stub_Type_Operation --
272 ---------------------------------
274 function Is_RACW_Stub_Type_Operation
(Op
: Entity_Id
) return Boolean is
282 Typ
:= Find_Dispatching_Type
(Op
);
286 and then Is_RACW_Stub_Type
(Typ
)
287 and then not Is_Internal
(Op
);
292 end Is_RACW_Stub_Type_Operation
;
294 ---------------------------------
295 -- Is_Valid_Remote_Object_Type --
296 ---------------------------------
298 function Is_Valid_Remote_Object_Type
(E
: Entity_Id
) return Boolean is
299 P
: constant Node_Id
:= Parent
(E
);
302 pragma Assert
(Is_Tagged_Type
(E
));
304 -- Simple case: a limited private type
306 if Nkind
(P
) = N_Private_Type_Declaration
307 and then Is_Limited_Record
(E
)
311 -- AI05-0060 (Binding Interpretation): A limited interface is a legal
312 -- ancestor for the designated type of an RACW type.
314 elsif Is_Limited_Record
(E
) and then Is_Limited_Interface
(E
) then
317 -- A generic tagged limited type is a valid candidate. Limitedness will
318 -- be checked again on the actual at instantiation point.
320 elsif Nkind
(P
) = N_Formal_Type_Declaration
321 and then Ekind
(E
) = E_Record_Type_With_Private
322 and then Is_Generic_Type
(E
)
323 and then Is_Limited_Record
(E
)
327 -- A private extension declaration is a valid candidate if its parent
330 elsif Nkind
(P
) = N_Private_Extension_Declaration
then
331 return Is_Valid_Remote_Object_Type
(Etype
(E
));
336 end Is_Valid_Remote_Object_Type
;
338 ------------------------------------
339 -- Package_Specification_Of_Scope --
340 ------------------------------------
342 function Package_Specification_Of_Scope
(E
: Entity_Id
) return Node_Id
is
347 while Nkind
(N
) /= N_Package_Specification
loop
352 end Package_Specification_Of_Scope
;
354 --------------------------
355 -- Process_Partition_Id --
356 --------------------------
358 procedure Process_Partition_Id
(N
: Node_Id
) is
359 Loc
: constant Source_Ptr
:= Sloc
(N
);
362 Get_Pt_Id_Call
: Node_Id
;
363 Prefix_String
: String_Id
;
364 Typ
: constant Entity_Id
:= Etype
(N
);
367 -- In case prefix is not a library unit entity, get the entity
370 Ety
:= Entity
(Prefix
(N
));
371 while (Present
(Scope
(Ety
))
372 and then Scope
(Ety
) /= Standard_Standard
)
373 and not Is_Child_Unit
(Ety
)
378 -- Retrieve the proper function to call
380 if Is_Remote_Call_Interface
(Ety
) then
381 Get_Pt_Id
:= New_Occurrence_Of
382 (RTE
(RE_Get_Active_Partition_Id
), Loc
);
384 elsif Is_Shared_Passive
(Ety
) then
385 Get_Pt_Id
:= New_Occurrence_Of
386 (RTE
(RE_Get_Passive_Partition_Id
), Loc
);
389 Get_Pt_Id
:= New_Occurrence_Of
390 (RTE
(RE_Get_Local_Partition_Id
), Loc
);
393 -- Get and store the String_Id corresponding to the name of the
394 -- library unit whose Partition_Id is needed.
396 Get_Library_Unit_Name_String
(Unit_Declaration_Node
(Ety
));
397 Prefix_String
:= String_From_Name_Buffer
;
399 -- Build the function call which will replace the attribute
401 if Is_Remote_Call_Interface
(Ety
) or else Is_Shared_Passive
(Ety
) then
403 Make_Function_Call
(Loc
,
405 Parameter_Associations
=>
406 New_List
(Make_String_Literal
(Loc
, Prefix_String
)));
409 Get_Pt_Id_Call
:= Make_Function_Call
(Loc
, Get_Pt_Id
);
412 -- Replace the attribute node by a conversion of the function call
413 -- to the target type.
415 Rewrite
(N
, Convert_To
(Typ
, Get_Pt_Id_Call
));
416 Analyze_And_Resolve
(N
, Typ
);
417 end Process_Partition_Id
;
419 ----------------------------------
420 -- Process_Remote_AST_Attribute --
421 ----------------------------------
423 procedure Process_Remote_AST_Attribute
425 New_Type
: Entity_Id
)
427 Loc
: constant Source_Ptr
:= Sloc
(N
);
428 Remote_Subp
: Entity_Id
;
429 Tick_Access_Conv_Call
: Node_Id
;
430 Remote_Subp_Decl
: Node_Id
;
431 RS_Pkg_Specif
: Node_Id
;
432 RS_Pkg_E
: Entity_Id
;
433 RAS_Type
: Entity_Id
:= New_Type
;
435 All_Calls_Remote_E
: Entity_Id
;
436 Attribute_Subp
: Entity_Id
;
439 -- Check if we have to expand the access attribute
441 Remote_Subp
:= Entity
(Prefix
(N
));
443 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
447 if Ekind
(RAS_Type
) /= E_Record_Type
then
448 RAS_Type
:= Equivalent_Type
(RAS_Type
);
451 Attribute_Subp
:= TSS
(RAS_Type
, TSS_RAS_Access
);
452 pragma Assert
(Present
(Attribute_Subp
));
453 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
455 if Nkind
(Remote_Subp_Decl
) = N_Subprogram_Body
then
456 Remote_Subp
:= Corresponding_Spec
(Remote_Subp_Decl
);
457 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
460 RS_Pkg_Specif
:= Parent
(Remote_Subp_Decl
);
461 RS_Pkg_E
:= Defining_Entity
(RS_Pkg_Specif
);
464 Boolean_Literals
(Ekind
(Remote_Subp
) = E_Procedure
465 and then Is_Asynchronous
(Remote_Subp
));
467 All_Calls_Remote_E
:=
468 Boolean_Literals
(Has_All_Calls_Remote
(RS_Pkg_E
));
470 Tick_Access_Conv_Call
:=
471 Make_Function_Call
(Loc
,
472 Name
=> New_Occurrence_Of
(Attribute_Subp
, Loc
),
473 Parameter_Associations
=>
475 Make_String_Literal
(Loc
,
476 Strval
=> Full_Qualified_Name
(RS_Pkg_E
)),
477 Build_Subprogram_Id
(Loc
, Remote_Subp
),
478 New_Occurrence_Of
(Async_E
, Loc
),
479 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
)));
481 Rewrite
(N
, Tick_Access_Conv_Call
);
482 Analyze_And_Resolve
(N
, RAS_Type
);
483 end Process_Remote_AST_Attribute
;
485 ------------------------------------
486 -- Process_Remote_AST_Declaration --
487 ------------------------------------
489 procedure Process_Remote_AST_Declaration
(N
: Node_Id
) is
490 Loc
: constant Source_Ptr
:= Sloc
(N
);
491 User_Type
: constant Node_Id
:= Defining_Identifier
(N
);
492 Scop
: constant Entity_Id
:= Scope
(User_Type
);
493 Is_RCI
: constant Boolean := Is_Remote_Call_Interface
(Scop
);
494 Is_RT
: constant Boolean := Is_Remote_Types
(Scop
);
495 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
498 Is_Degenerate
: Boolean;
499 -- True iff this RAS has an access formal parameter (see
500 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
502 Subpkg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
503 Subpkg_Decl
: Node_Id
;
504 Subpkg_Body
: Node_Id
;
505 Vis_Decls
: constant List_Id
:= New_List
;
506 Priv_Decls
: constant List_Id
:= New_List
;
508 Obj_Type
: constant Entity_Id
:=
509 Make_Defining_Identifier
(Loc
,
510 New_External_Name
(Chars
(User_Type
), 'R'));
512 Full_Obj_Type
: constant Entity_Id
:=
513 Make_Defining_Identifier
(Loc
, Chars
(Obj_Type
));
515 RACW_Type
: constant Entity_Id
:=
516 Make_Defining_Identifier
(Loc
,
517 New_External_Name
(Chars
(User_Type
), 'P'));
519 Fat_Type
: constant Entity_Id
:=
520 Make_Defining_Identifier
(Loc
, Chars
(User_Type
));
522 Fat_Type_Decl
: Node_Id
;
525 Is_Degenerate
:= False;
526 Parameter
:= First
(Parameter_Specifications
(Type_Def
));
527 while Present
(Parameter
) loop
528 if Nkind
(Parameter_Type
(Parameter
)) = N_Access_Definition
then
530 ("formal parameter& has anonymous access type??",
531 Defining_Identifier
(Parameter
));
532 Is_Degenerate
:= True;
539 if Is_Degenerate
then
541 ("remote access-to-subprogram type& can only be null??",
542 Defining_Identifier
(Parameter
), User_Type
);
544 -- The only legal value for a RAS with a formal parameter of an
545 -- anonymous access type is null, because it cannot be subtype-
546 -- conformant with any legal remote subprogram declaration. In this
547 -- case, we cannot generate a corresponding primitive operation.
551 if Get_PCS_Name
= Name_No_DSA
then
555 -- The tagged private type, primitive operation and RACW type associated
556 -- with a RAS need to all be declared in a subpackage of the one that
557 -- contains the RAS declaration, because the primitive of the object
558 -- type, and the associated primitive of the stub type, need to be
559 -- dispatching operations of these types, and the profile of the RAS
560 -- might contain tagged types declared in the same scope.
562 Append_To
(Vis_Decls
,
563 Make_Private_Type_Declaration
(Loc
,
564 Defining_Identifier
=> Obj_Type
,
565 Abstract_Present
=> True,
566 Tagged_Present
=> True,
567 Limited_Present
=> True));
569 Append_To
(Priv_Decls
,
570 Make_Full_Type_Declaration
(Loc
,
571 Defining_Identifier
=> Full_Obj_Type
,
573 Make_Record_Definition
(Loc
,
574 Abstract_Present
=> True,
575 Tagged_Present
=> True,
576 Limited_Present
=> True,
577 Null_Present
=> True,
578 Component_List
=> Empty
)));
580 -- Trick semantic analysis into swapping the public and full view when
581 -- freezing the public view.
583 Set_Comes_From_Source
(Full_Obj_Type
, True);
585 if not Is_Degenerate
then
586 Append_To
(Vis_Decls
,
587 Make_Abstract_Subprogram_Declaration
(Loc
,
588 Specification
=> Build_RAS_Primitive_Specification
(
589 Subp_Spec
=> Type_Def
,
590 Remote_Object_Type
=> Obj_Type
)));
593 Append_To
(Vis_Decls
,
594 Make_Full_Type_Declaration
(Loc
,
595 Defining_Identifier
=> RACW_Type
,
597 Make_Access_To_Object_Definition
(Loc
,
599 Subtype_Indication
=>
600 Make_Attribute_Reference
(Loc
,
601 Prefix
=> New_Occurrence_Of
(Obj_Type
, Loc
),
602 Attribute_Name
=> Name_Class
))));
604 Set_Is_Remote_Call_Interface
(RACW_Type
, Is_RCI
);
605 Set_Is_Remote_Types
(RACW_Type
, Is_RT
);
608 Make_Package_Declaration
(Loc
,
609 Make_Package_Specification
(Loc
,
610 Defining_Unit_Name
=> Subpkg
,
611 Visible_Declarations
=> Vis_Decls
,
612 Private_Declarations
=> Priv_Decls
,
613 End_Label
=> New_Occurrence_Of
(Subpkg
, Loc
)));
615 Set_Is_Remote_Call_Interface
(Subpkg
, Is_RCI
);
616 Set_Is_Remote_Types
(Subpkg
, Is_RT
);
617 Insert_After_And_Analyze
(N
, Subpkg_Decl
);
619 -- Generate package body to receive RACW calling stubs
621 -- Note: Analyze_Declarations has an absolute requirement that the
622 -- declaration list be non-empty, so provide dummy null statement here.
625 Make_Package_Body
(Loc
,
626 Defining_Unit_Name
=> Make_Defining_Identifier
(Loc
, Chars
(Subpkg
)),
627 Declarations
=> New_List
(Make_Null_Statement
(Loc
)));
628 Insert_After_And_Analyze
(Subpkg_Decl
, Subpkg_Body
);
630 -- Many parts of the analyzer and expander expect
631 -- that the fat pointer type used to implement remote
632 -- access to subprogram types be a record.
633 -- Note: The structure of this type must be kept consistent
634 -- with the code generated by Remote_AST_Null_Value for the
635 -- corresponding 'null' expression.
637 Fat_Type_Decl
:= Make_Full_Type_Declaration
(Loc
,
638 Defining_Identifier
=> Fat_Type
,
640 Make_Record_Definition
(Loc
,
642 Make_Component_List
(Loc
,
643 Component_Items
=> New_List
(
644 Make_Component_Declaration
(Loc
,
645 Defining_Identifier
=>
646 Make_Defining_Identifier
(Loc
, Name_Ras
),
647 Component_Definition
=>
648 Make_Component_Definition
(Loc
,
649 Aliased_Present
=> False,
650 Subtype_Indication
=>
651 New_Occurrence_Of
(RACW_Type
, Loc
)))))));
653 Set_Equivalent_Type
(User_Type
, Fat_Type
);
655 -- Set Fat_Type's Etype early so that we can use its
656 -- Corresponding_Remote_Type attribute, whose presence indicates that
657 -- this is the record type used to implement a RAS.
659 Set_Ekind
(Fat_Type
, E_Record_Type
);
660 Set_Corresponding_Remote_Type
(Fat_Type
, User_Type
);
662 Insert_After_And_Analyze
(Subpkg_Body
, Fat_Type_Decl
);
664 -- The reason we suppress the initialization procedure is that we know
665 -- that no initialization is required (even if Initialize_Scalars mode
666 -- is active), and there are order of elaboration problems if we do try
667 -- to generate an init proc for this created record type.
669 Set_Suppress_Initialization
(Fat_Type
);
671 if Expander_Active
then
672 Add_RAST_Features
(Parent
(User_Type
));
674 end Process_Remote_AST_Declaration
;
676 -----------------------
677 -- RAS_E_Dereference --
678 -----------------------
680 procedure RAS_E_Dereference
(Pref
: Node_Id
) is
681 Loc
: constant Source_Ptr
:= Sloc
(Pref
);
683 New_Type
: constant Entity_Id
:= Etype
(Pref
);
684 Explicit_Deref
: constant Node_Id
:= Parent
(Pref
);
685 Deref_Subp_Call
: constant Node_Id
:= Parent
(Explicit_Deref
);
686 Deref_Proc
: Entity_Id
;
690 if Nkind
(Deref_Subp_Call
) = N_Procedure_Call_Statement
then
691 Params
:= Parameter_Associations
(Deref_Subp_Call
);
693 if Present
(Params
) then
694 Prepend
(Pref
, Params
);
696 Params
:= New_List
(Pref
);
699 elsif Nkind
(Deref_Subp_Call
) = N_Indexed_Component
then
700 Params
:= Expressions
(Deref_Subp_Call
);
702 if Present
(Params
) then
703 Prepend
(Pref
, Params
);
705 Params
:= New_List
(Pref
);
709 -- Context is not a call
714 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
718 Deref_Proc
:= TSS
(New_Type
, TSS_RAS_Dereference
);
719 pragma Assert
(Present
(Deref_Proc
));
721 if Ekind
(Deref_Proc
) = E_Function
then
723 Make_Function_Call
(Loc
,
724 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
725 Parameter_Associations
=> Params
);
728 Make_Procedure_Call_Statement
(Loc
,
729 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
730 Parameter_Associations
=> Params
);
733 Rewrite
(Deref_Subp_Call
, Call_Node
);
734 Analyze
(Deref_Subp_Call
);
735 end RAS_E_Dereference
;
737 ------------------------------
738 -- Remote_AST_E_Dereference --
739 ------------------------------
741 function Remote_AST_E_Dereference
(P
: Node_Id
) return Boolean is
742 ET
: constant Entity_Id
:= Etype
(P
);
745 -- Perform the changes only on original dereferences, and only if
746 -- we are generating code.
748 if Comes_From_Source
(P
)
749 and then Is_Record_Type
(ET
)
750 and then (Is_Remote_Call_Interface
(ET
)
751 or else Is_Remote_Types
(ET
))
752 and then Present
(Corresponding_Remote_Type
(ET
))
753 and then Nkind_In
(Parent
(Parent
(P
)), N_Procedure_Call_Statement
,
755 and then Expander_Active
757 RAS_E_Dereference
(P
);
762 end Remote_AST_E_Dereference
;
764 ------------------------------
765 -- Remote_AST_I_Dereference --
766 ------------------------------
768 function Remote_AST_I_Dereference
(P
: Node_Id
) return Boolean is
769 ET
: constant Entity_Id
:= Etype
(P
);
773 if Comes_From_Source
(P
)
774 and then (Is_Remote_Call_Interface
(ET
)
775 or else Is_Remote_Types
(ET
))
776 and then Present
(Corresponding_Remote_Type
(ET
))
777 and then Ekind
(Entity
(P
)) /= E_Function
780 Make_Explicit_Dereference
(Sloc
(P
),
781 Prefix
=> Relocate_Node
(P
));
784 RAS_E_Dereference
(Prefix
(P
));
789 end Remote_AST_I_Dereference
;
791 ---------------------------
792 -- Remote_AST_Null_Value --
793 ---------------------------
795 function Remote_AST_Null_Value
797 Typ
: Entity_Id
) return Boolean
799 Loc
: constant Source_Ptr
:= Sloc
(N
);
800 Target_Type
: Entity_Id
;
803 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
806 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
807 and then (Is_Remote_Call_Interface
(Typ
)
808 or else Is_Remote_Types
(Typ
))
809 and then Comes_From_Source
(N
)
810 and then Expander_Active
812 -- Any null that comes from source and is of the RAS type must
813 -- be expanded, except if expansion is not active (nothing
814 -- gets expanded into the equivalent record type).
816 Target_Type
:= Equivalent_Type
(Typ
);
818 elsif Ekind
(Typ
) = E_Record_Type
819 and then Present
(Corresponding_Remote_Type
(Typ
))
821 -- This is a record type representing a RAS type, this must be
827 -- We do not have to handle this case
834 Component_Associations
=> New_List
(
835 Make_Component_Association
(Loc
,
836 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Ras
)),
837 Expression
=> Make_Null
(Loc
)))));
838 Analyze_And_Resolve
(N
, Target_Type
);
840 end Remote_AST_Null_Value
;