1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Einfo
.Entities
; use Einfo
.Entities
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Errout
; use Errout
;
32 with Exp_Dist
; use Exp_Dist
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
36 with Namet
; use Namet
;
38 with Rtsfind
; use Rtsfind
;
40 with Sem_Aux
; use Sem_Aux
;
41 with Sem_Disp
; use Sem_Disp
;
42 with Sem_Eval
; use Sem_Eval
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sinfo
; use Sinfo
;
46 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
47 with Sinfo
.Utils
; use Sinfo
.Utils
;
48 with Stand
; use Stand
;
49 with Stringt
; use Stringt
;
50 with Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
53 package body Sem_Dist
is
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
59 procedure RAS_E_Dereference
(Pref
: Node_Id
);
60 -- Handles explicit dereference of Remote Access to Subprograms
62 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
;
63 -- returns the full qualified name of the entity in lower case
65 -------------------------
66 -- Add_Stub_Constructs --
67 -------------------------
69 procedure Add_Stub_Constructs
(N
: Node_Id
) is
70 U
: constant Node_Id
:= Unit
(N
);
71 Spec
: Entity_Id
:= Empty
;
74 -- Unit that will be expanded
77 pragma Assert
(Distribution_Stub_Mode
/= No_Stubs
);
79 if Nkind
(U
) = N_Package_Declaration
then
80 Spec
:= Defining_Entity
(Specification
(U
));
82 elsif Nkind
(U
) = N_Package_Body
then
83 Spec
:= Corresponding_Spec
(U
);
85 else pragma Assert
(Nkind
(U
) = N_Package_Instantiation
);
86 Exp
:= Instance_Spec
(U
);
87 Spec
:= Defining_Entity
(Specification
(Exp
));
90 pragma Assert
(Is_Shared_Passive
(Spec
)
91 or else Is_Remote_Call_Interface
(Spec
));
93 if Distribution_Stub_Mode
= Generate_Caller_Stub_Body
then
94 if Is_Shared_Passive
(Spec
) then
96 elsif Nkind
(U
) = N_Package_Body
then
98 ("Specification file expected from command line", U
);
100 Expand_Calling_Stubs_Bodies
(Exp
);
104 if Is_Shared_Passive
(Spec
) then
105 Build_Passive_Partition_Stub
(Exp
);
107 Expand_Receiving_Stubs_Bodies
(Exp
);
111 end Add_Stub_Constructs
;
113 ---------------------------------------
114 -- Build_RAS_Primitive_Specification --
115 ---------------------------------------
117 function Build_RAS_Primitive_Specification
118 (Subp_Spec
: Node_Id
;
119 Remote_Object_Type
: Node_Id
) return Node_Id
121 Loc
: constant Source_Ptr
:= Sloc
(Subp_Spec
);
123 Primitive_Spec
: constant Node_Id
:=
124 Copy_Specification
(Loc
,
126 New_Name
=> Name_uCall
);
128 Subtype_Mark_For_Self
: Node_Id
;
131 if No
(Parameter_Specifications
(Primitive_Spec
)) then
132 Set_Parameter_Specifications
(Primitive_Spec
, New_List
);
135 if Nkind
(Remote_Object_Type
) in N_Entity
then
136 Subtype_Mark_For_Self
:=
137 New_Occurrence_Of
(Remote_Object_Type
, Loc
);
139 Subtype_Mark_For_Self
:= Remote_Object_Type
;
143 Parameter_Specifications
(Primitive_Spec
),
144 Make_Parameter_Specification
(Loc
,
145 Defining_Identifier
=>
146 Make_Defining_Identifier
(Loc
, Name_uS
),
148 Make_Access_Definition
(Loc
,
150 Subtype_Mark_For_Self
)));
152 -- Trick later semantic analysis into considering this operation as a
153 -- primitive (dispatching) operation of tagged type Obj_Type.
155 Set_Comes_From_Source
(
156 Defining_Unit_Name
(Primitive_Spec
), True);
158 return Primitive_Spec
;
159 end Build_RAS_Primitive_Specification
;
161 -------------------------
162 -- Full_Qualified_Name --
163 -------------------------
165 function Full_Qualified_Name
(E
: Entity_Id
) return String_Id
is
166 Ent
: Entity_Id
:= E
;
167 Parent_Name
: String_Id
:= No_String
;
170 -- Deals properly with child units
172 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
173 Ent
:= Defining_Identifier
(Ent
);
176 -- Compute recursively the qualification (only "Standard" has no scope)
178 if Present
(Scope
(Scope
(Ent
))) then
179 Parent_Name
:= Full_Qualified_Name
(Scope
(Ent
));
182 -- Every entity should have a name except some expanded blocks. Do not
183 -- bother about those.
185 if Chars
(Ent
) = No_Name
then
189 -- Add a period between Name and qualification
191 if Parent_Name
/= No_String
then
192 Start_String
(Parent_Name
);
193 Store_String_Char
(Get_Char_Code
('.'));
198 -- Generates the entity name in upper case
200 Get_Name_String
(Chars
(Ent
));
201 Set_Casing
(All_Lower_Case
);
202 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
204 end Full_Qualified_Name
;
210 function Get_PCS_Name
return PCS_Names
is
213 Chars
(Entity
(Expression
(Parent
(RTE
(RE_DSA_Implementation
)))));
216 ---------------------
217 -- Get_PCS_Version --
218 ---------------------
220 function Get_PCS_Version
return Int
is
221 PCS_Version_Entity
: Entity_Id
;
225 if RTE_Available
(RE_PCS_Version
) then
226 PCS_Version_Entity
:= RTE
(RE_PCS_Version
);
227 pragma Assert
(Ekind
(PCS_Version_Entity
) = E_Named_Integer
);
229 UI_To_Int
(Expr_Value
(Constant_Value
(PCS_Version_Entity
)));
232 -- Case of System.Partition_Interface.PCS_Version not found:
233 -- return a null version.
241 ------------------------
242 -- Is_All_Remote_Call --
243 ------------------------
245 function Is_All_Remote_Call
(N
: Node_Id
) return Boolean is
249 if Nkind
(N
) in N_Subprogram_Call
250 and then Nkind
(Name
(N
)) in N_Has_Entity
251 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
252 and then Has_All_Calls_Remote
(Scope
(Entity
(Name
(N
))))
253 and then Comes_From_Source
(N
)
255 Par
:= Parent
(Entity
(Name
(N
)));
257 and then (Nkind
(Par
) /= N_Package_Specification
258 or else Is_Wrapper_Package
(Defining_Entity
(Par
)))
263 if Present
(Par
) then
265 not Scope_Within_Or_Same
(Current_Scope
, Defining_Entity
(Par
));
272 end Is_All_Remote_Call
;
274 ---------------------------------
275 -- Is_RACW_Stub_Type_Operation --
276 ---------------------------------
278 function Is_RACW_Stub_Type_Operation
(Op
: Entity_Id
) return Boolean is
286 Typ
:= Find_Dispatching_Type
(Op
);
290 and then Is_RACW_Stub_Type
(Typ
)
291 and then not Is_Internal
(Op
);
296 end Is_RACW_Stub_Type_Operation
;
298 ---------------------------------
299 -- Is_Valid_Remote_Object_Type --
300 ---------------------------------
302 function Is_Valid_Remote_Object_Type
(E
: Entity_Id
) return Boolean is
303 P
: constant Node_Id
:= Parent
(E
);
306 pragma Assert
(Is_Tagged_Type
(E
));
308 -- Simple case: a limited private type
310 if Nkind
(P
) = N_Private_Type_Declaration
311 and then Is_Limited_Record
(E
)
315 -- AI05-0060 (Binding Interpretation): A limited interface is a legal
316 -- ancestor for the designated type of an RACW type.
318 elsif Is_Limited_Record
(E
) and then Is_Limited_Interface
(E
) then
321 -- A generic tagged limited type is a valid candidate. Limitedness will
322 -- be checked again on the actual at instantiation point.
324 elsif Nkind
(P
) = N_Formal_Type_Declaration
325 and then Ekind
(E
) = E_Record_Type_With_Private
326 and then Is_Generic_Type
(E
)
327 and then Is_Limited_Record
(E
)
331 -- A private extension declaration is a valid candidate if its parent
334 elsif Nkind
(P
) = N_Private_Extension_Declaration
then
335 return Is_Valid_Remote_Object_Type
(Etype
(E
));
340 end Is_Valid_Remote_Object_Type
;
342 ------------------------------------
343 -- Package_Specification_Of_Scope --
344 ------------------------------------
346 function Package_Specification_Of_Scope
(E
: Entity_Id
) return Node_Id
is
351 while Nkind
(N
) /= N_Package_Specification
loop
356 end Package_Specification_Of_Scope
;
358 --------------------------
359 -- Process_Partition_Id --
360 --------------------------
362 procedure Process_Partition_Id
(N
: Node_Id
) is
363 Loc
: constant Source_Ptr
:= Sloc
(N
);
366 Get_Pt_Id_Call
: Node_Id
;
367 Prefix_String
: String_Id
;
368 Typ
: constant Entity_Id
:= Etype
(N
);
371 -- In case prefix is not a library unit entity, get the entity
374 Ety
:= Entity
(Prefix
(N
));
375 while (Present
(Scope
(Ety
))
376 and then Scope
(Ety
) /= Standard_Standard
)
377 and not Is_Child_Unit
(Ety
)
382 -- Retrieve the proper function to call
384 if Is_Remote_Call_Interface
(Ety
) then
385 Get_Pt_Id
:= New_Occurrence_Of
386 (RTE
(RE_Get_Active_Partition_Id
), Loc
);
388 elsif Is_Shared_Passive
(Ety
) then
389 Get_Pt_Id
:= New_Occurrence_Of
390 (RTE
(RE_Get_Passive_Partition_Id
), Loc
);
393 Get_Pt_Id
:= New_Occurrence_Of
394 (RTE
(RE_Get_Local_Partition_Id
), Loc
);
397 -- Get the String_Id corresponding to the name of the library unit whose
398 -- Partition_Id is needed.
400 Prefix_String
:= Get_Library_Unit_Name
(Unit_Declaration_Node
(Ety
));
402 -- Build the function call which will replace the attribute
404 if Is_Remote_Call_Interface
(Ety
) or else Is_Shared_Passive
(Ety
) then
406 Make_Function_Call
(Loc
,
408 Parameter_Associations
=>
409 New_List
(Make_String_Literal
(Loc
, Prefix_String
)));
412 Get_Pt_Id_Call
:= Make_Function_Call
(Loc
, Get_Pt_Id
);
415 -- Replace the attribute node by a conversion of the function call
416 -- to the target type.
418 Rewrite
(N
, Convert_To
(Typ
, Get_Pt_Id_Call
));
419 Analyze_And_Resolve
(N
, Typ
);
420 end Process_Partition_Id
;
422 ----------------------------------
423 -- Process_Remote_AST_Attribute --
424 ----------------------------------
426 procedure Process_Remote_AST_Attribute
428 New_Type
: Entity_Id
)
430 Loc
: constant Source_Ptr
:= Sloc
(N
);
431 Remote_Subp
: Entity_Id
;
432 Tick_Access_Conv_Call
: Node_Id
;
433 Remote_Subp_Decl
: Node_Id
;
434 RS_Pkg_Specif
: Node_Id
;
435 RS_Pkg_E
: Entity_Id
;
436 RAS_Type
: Entity_Id
:= New_Type
;
438 All_Calls_Remote_E
: Entity_Id
;
439 Attribute_Subp
: Entity_Id
;
442 -- Check if we have to expand the access attribute
444 Remote_Subp
:= Entity
(Prefix
(N
));
446 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
450 if Ekind
(RAS_Type
) /= E_Record_Type
then
451 RAS_Type
:= Equivalent_Type
(RAS_Type
);
454 Attribute_Subp
:= TSS
(RAS_Type
, TSS_RAS_Access
);
455 pragma Assert
(Present
(Attribute_Subp
));
456 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
458 if Nkind
(Remote_Subp_Decl
) = N_Subprogram_Body
then
459 Remote_Subp
:= Corresponding_Spec
(Remote_Subp_Decl
);
460 Remote_Subp_Decl
:= Unit_Declaration_Node
(Remote_Subp
);
463 RS_Pkg_Specif
:= Parent
(Remote_Subp_Decl
);
464 RS_Pkg_E
:= Defining_Entity
(RS_Pkg_Specif
);
467 Boolean_Literals
(Ekind
(Remote_Subp
) = E_Procedure
468 and then Is_Asynchronous
(Remote_Subp
));
470 All_Calls_Remote_E
:=
471 Boolean_Literals
(Has_All_Calls_Remote
(RS_Pkg_E
));
473 Tick_Access_Conv_Call
:=
474 Make_Function_Call
(Loc
,
475 Name
=> New_Occurrence_Of
(Attribute_Subp
, Loc
),
476 Parameter_Associations
=>
478 Make_String_Literal
(Loc
,
479 Strval
=> Full_Qualified_Name
(RS_Pkg_E
)),
480 Build_Subprogram_Id
(Loc
, Remote_Subp
),
481 New_Occurrence_Of
(Async_E
, Loc
),
482 New_Occurrence_Of
(All_Calls_Remote_E
, Loc
)));
484 Rewrite
(N
, Tick_Access_Conv_Call
);
485 Analyze_And_Resolve
(N
, RAS_Type
);
486 end Process_Remote_AST_Attribute
;
488 ------------------------------------
489 -- Process_Remote_AST_Declaration --
490 ------------------------------------
492 procedure Process_Remote_AST_Declaration
(N
: Node_Id
) is
493 Loc
: constant Source_Ptr
:= Sloc
(N
);
494 User_Type
: constant Node_Id
:= Defining_Identifier
(N
);
495 Scop
: constant Entity_Id
:= Scope
(User_Type
);
496 Is_RCI
: constant Boolean := Is_Remote_Call_Interface
(Scop
);
497 Is_RT
: constant Boolean := Is_Remote_Types
(Scop
);
498 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
501 Is_Degenerate
: Boolean;
502 -- True iff this RAS has an access formal parameter (see
503 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
505 Subpkg
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
506 Subpkg_Decl
: Node_Id
;
507 Subpkg_Body
: Node_Id
;
508 Vis_Decls
: constant List_Id
:= New_List
;
509 Priv_Decls
: constant List_Id
:= New_List
;
511 Obj_Type
: constant Entity_Id
:=
512 Make_Defining_Identifier
(Loc
,
513 New_External_Name
(Chars
(User_Type
), 'R'));
515 Full_Obj_Type
: constant Entity_Id
:=
516 Make_Defining_Identifier
(Loc
, Chars
(Obj_Type
));
518 RACW_Type
: constant Entity_Id
:=
519 Make_Defining_Identifier
(Loc
,
520 New_External_Name
(Chars
(User_Type
), 'P'));
522 Fat_Type
: constant Entity_Id
:=
523 Make_Defining_Identifier
(Loc
, Chars
(User_Type
));
525 Fat_Type_Decl
: Node_Id
;
528 Is_Degenerate
:= False;
529 Parameter
:= First
(Parameter_Specifications
(Type_Def
));
530 while Present
(Parameter
) loop
531 if Nkind
(Parameter_Type
(Parameter
)) = N_Access_Definition
then
533 ("formal parameter& has anonymous access type??",
534 Defining_Identifier
(Parameter
));
535 Is_Degenerate
:= True;
542 if Is_Degenerate
then
544 ("remote access-to-subprogram type& can only be null??",
545 Defining_Identifier
(Parameter
), User_Type
);
547 -- The only legal value for a RAS with a formal parameter of an
548 -- anonymous access type is null, because it cannot be subtype-
549 -- conformant with any legal remote subprogram declaration. In this
550 -- case, we cannot generate a corresponding primitive operation.
554 if Get_PCS_Name
= Name_No_DSA
then
558 -- The tagged private type, primitive operation and RACW type associated
559 -- with a RAS need to all be declared in a subpackage of the one that
560 -- contains the RAS declaration, because the primitive of the object
561 -- type, and the associated primitive of the stub type, need to be
562 -- dispatching operations of these types, and the profile of the RAS
563 -- might contain tagged types declared in the same scope.
565 Append_To
(Vis_Decls
,
566 Make_Private_Type_Declaration
(Loc
,
567 Defining_Identifier
=> Obj_Type
,
568 Abstract_Present
=> True,
569 Tagged_Present
=> True,
570 Limited_Present
=> True));
572 Append_To
(Priv_Decls
,
573 Make_Full_Type_Declaration
(Loc
,
574 Defining_Identifier
=> Full_Obj_Type
,
576 Make_Record_Definition
(Loc
,
577 Abstract_Present
=> True,
578 Tagged_Present
=> True,
579 Limited_Present
=> True,
580 Null_Present
=> True,
581 Component_List
=> Empty
)));
583 -- Trick semantic analysis into swapping the public and full view when
584 -- freezing the public view.
586 Set_Comes_From_Source
(Full_Obj_Type
, True);
588 if not Is_Degenerate
then
589 Append_To
(Vis_Decls
,
590 Make_Abstract_Subprogram_Declaration
(Loc
,
591 Specification
=> Build_RAS_Primitive_Specification
(
592 Subp_Spec
=> Type_Def
,
593 Remote_Object_Type
=> Obj_Type
)));
596 Append_To
(Vis_Decls
,
597 Make_Full_Type_Declaration
(Loc
,
598 Defining_Identifier
=> RACW_Type
,
600 Make_Access_To_Object_Definition
(Loc
,
602 Subtype_Indication
=>
603 Make_Attribute_Reference
(Loc
,
604 Prefix
=> New_Occurrence_Of
(Obj_Type
, Loc
),
605 Attribute_Name
=> Name_Class
))));
607 Set_Is_Remote_Call_Interface
(RACW_Type
, Is_RCI
);
608 Set_Is_Remote_Types
(RACW_Type
, Is_RT
);
611 Make_Package_Declaration
(Loc
,
612 Make_Package_Specification
(Loc
,
613 Defining_Unit_Name
=> Subpkg
,
614 Visible_Declarations
=> Vis_Decls
,
615 Private_Declarations
=> Priv_Decls
,
616 End_Label
=> New_Occurrence_Of
(Subpkg
, Loc
)));
618 Set_Is_Remote_Call_Interface
(Subpkg
, Is_RCI
);
619 Set_Is_Remote_Types
(Subpkg
, Is_RT
);
620 Insert_After_And_Analyze
(N
, Subpkg_Decl
);
622 -- Generate package body to receive RACW calling stubs
624 -- Note: Analyze_Declarations has an absolute requirement that the
625 -- declaration list be non-empty, so provide dummy null statement here.
628 Make_Package_Body
(Loc
,
629 Defining_Unit_Name
=> Make_Defining_Identifier
(Loc
, Chars
(Subpkg
)),
630 Declarations
=> New_List
(Make_Null_Statement
(Loc
)));
631 Insert_After_And_Analyze
(Subpkg_Decl
, Subpkg_Body
);
633 -- Many parts of the analyzer and expander expect
634 -- that the fat pointer type used to implement remote
635 -- access to subprogram types be a record.
636 -- Note: The structure of this type must be kept consistent
637 -- with the code generated by Remote_AST_Null_Value for the
638 -- corresponding 'null' expression.
640 Fat_Type_Decl
:= Make_Full_Type_Declaration
(Loc
,
641 Defining_Identifier
=> Fat_Type
,
643 Make_Record_Definition
(Loc
,
645 Make_Component_List
(Loc
,
646 Component_Items
=> New_List
(
647 Make_Component_Declaration
(Loc
,
648 Defining_Identifier
=>
649 Make_Defining_Identifier
(Loc
, Name_Ras
),
650 Component_Definition
=>
651 Make_Component_Definition
(Loc
,
652 Aliased_Present
=> False,
653 Subtype_Indication
=>
654 New_Occurrence_Of
(RACW_Type
, Loc
)))))));
656 Set_Equivalent_Type
(User_Type
, Fat_Type
);
658 -- Set Fat_Type's Etype early so that we can use its
659 -- Corresponding_Remote_Type attribute, whose presence indicates that
660 -- this is the record type used to implement a RAS.
662 Mutate_Ekind
(Fat_Type
, E_Record_Type
);
663 Set_Corresponding_Remote_Type
(Fat_Type
, User_Type
);
665 Insert_After_And_Analyze
(Subpkg_Body
, Fat_Type_Decl
);
667 -- The reason we suppress the initialization procedure is that we know
668 -- that no initialization is required (even if Initialize_Scalars mode
669 -- is active), and there are order of elaboration problems if we do try
670 -- to generate an init proc for this created record type.
672 Set_Suppress_Initialization
(Fat_Type
);
674 if Expander_Active
then
675 Add_RAST_Features
(Parent
(User_Type
));
677 end Process_Remote_AST_Declaration
;
679 -----------------------
680 -- RAS_E_Dereference --
681 -----------------------
683 procedure RAS_E_Dereference
(Pref
: Node_Id
) is
684 Loc
: constant Source_Ptr
:= Sloc
(Pref
);
686 New_Type
: constant Entity_Id
:= Etype
(Pref
);
687 Explicit_Deref
: constant Node_Id
:= Parent
(Pref
);
688 Deref_Subp_Call
: constant Node_Id
:= Parent
(Explicit_Deref
);
689 Deref_Proc
: Entity_Id
;
693 if Nkind
(Deref_Subp_Call
) = N_Procedure_Call_Statement
then
694 Params
:= Parameter_Associations
(Deref_Subp_Call
);
696 if Present
(Params
) then
697 Prepend
(Pref
, Params
);
699 Params
:= New_List
(Pref
);
702 elsif Nkind
(Deref_Subp_Call
) = N_Indexed_Component
then
703 Params
:= Expressions
(Deref_Subp_Call
);
705 if Present
(Params
) then
706 Prepend
(Pref
, Params
);
708 Params
:= New_List
(Pref
);
712 -- Context is not a call
717 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
721 Deref_Proc
:= TSS
(New_Type
, TSS_RAS_Dereference
);
722 pragma Assert
(Present
(Deref_Proc
));
724 if Ekind
(Deref_Proc
) = E_Function
then
726 Make_Function_Call
(Loc
,
727 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
728 Parameter_Associations
=> Params
);
731 Make_Procedure_Call_Statement
(Loc
,
732 Name
=> New_Occurrence_Of
(Deref_Proc
, Loc
),
733 Parameter_Associations
=> Params
);
736 Rewrite
(Deref_Subp_Call
, Call_Node
);
737 Analyze
(Deref_Subp_Call
);
738 end RAS_E_Dereference
;
740 ------------------------------
741 -- Remote_AST_E_Dereference --
742 ------------------------------
744 function Remote_AST_E_Dereference
(P
: Node_Id
) return Boolean is
745 ET
: constant Entity_Id
:= Etype
(P
);
748 -- Perform the changes only on original dereferences, and only if
749 -- we are generating code.
751 if Comes_From_Source
(P
)
752 and then Expander_Active
753 and then Is_Record_Type
(ET
)
754 and then (Is_Remote_Call_Interface
(ET
) or else Is_Remote_Types
(ET
))
755 and then Present
(Corresponding_Remote_Type
(ET
))
756 and then Nkind
(Parent
(Parent
(P
))) in
757 N_Procedure_Call_Statement | N_Indexed_Component
759 RAS_E_Dereference
(P
);
764 end Remote_AST_E_Dereference
;
766 ------------------------------
767 -- Remote_AST_I_Dereference --
768 ------------------------------
770 function Remote_AST_I_Dereference
(P
: Node_Id
) return Boolean is
771 ET
: constant Entity_Id
:= Etype
(P
);
775 if Comes_From_Source
(P
)
776 and then (Is_Remote_Call_Interface
(ET
)
777 or else Is_Remote_Types
(ET
))
778 and then Present
(Corresponding_Remote_Type
(ET
))
779 and then Ekind
(Entity
(P
)) /= E_Function
782 Make_Explicit_Dereference
(Sloc
(P
),
783 Prefix
=> Relocate_Node
(P
));
786 RAS_E_Dereference
(Prefix
(P
));
791 end Remote_AST_I_Dereference
;
793 ---------------------------
794 -- Remote_AST_Null_Value --
795 ---------------------------
797 function Remote_AST_Null_Value
799 Typ
: Entity_Id
) return Boolean
801 Loc
: constant Source_Ptr
:= Sloc
(N
);
802 Target_Type
: Entity_Id
;
805 if not Expander_Active
or else Get_PCS_Name
= Name_No_DSA
then
808 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
809 and then (Is_Remote_Call_Interface
(Typ
)
810 or else Is_Remote_Types
(Typ
))
811 and then Comes_From_Source
(N
)
812 and then Expander_Active
814 -- Any null that comes from source and is of the RAS type must
815 -- be expanded, except if expansion is not active (nothing
816 -- gets expanded into the equivalent record type).
818 Target_Type
:= Equivalent_Type
(Typ
);
820 elsif Ekind
(Typ
) = E_Record_Type
821 and then Present
(Corresponding_Remote_Type
(Typ
))
823 -- This is a record type representing a RAS type, this must be
829 -- We do not have to handle this case
836 Component_Associations
=> New_List
(
837 Make_Component_Association
(Loc
,
838 Choices
=> New_List
(Make_Identifier
(Loc
, Name_Ras
)),
839 Expression
=> Make_Null
(Loc
)))));
840 Analyze_And_Resolve
(N
, Target_Type
);
842 end Remote_AST_Null_Value
;