1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005, 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;
206 function Get_PCS_Name return PCS_Names is
207 PCS_Name : constant PCS_Names :=
208 Chars (Entity (Expression
209 (Parent (RTE (RE_DSA_Implementation)))));
214 ------------------------
215 -- Is_All_Remote_Call --
216 ------------------------
218 function Is_All_Remote_Call (N : Node_Id) return Boolean is
222 if (Nkind (N) = N_Function_Call
223 or else Nkind (N) = N_Procedure_Call_Statement)
224 and then Nkind (Name (N)) in N_Has_Entity
225 and then Is_Remote_Call_Interface (Entity (Name (N)))
226 and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
227 and then Comes_From_Source (N)
229 Par := Parent (Entity (Name (N)));
232 and then (Nkind (Par) /= N_Package_Specification
233 or else Is_Wrapper_Package (Defining_Entity (Par)))
238 if Present (Par) then
240 not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
247 end Is_All_Remote_Call;
249 ------------------------------------
250 -- Package_Specification_Of_Scope --
251 ------------------------------------
253 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
254 N : Node_Id := Parent (E);
256 while Nkind (N) /= N_Package_Specification loop
261 end Package_Specification_Of_Scope;
263 --------------------------
264 -- Process_Partition_ID --
265 --------------------------
267 procedure Process_Partition_Id (N : Node_Id) is
268 Loc : constant Source_Ptr := Sloc (N);
271 Get_Pt_Id_Call : Node_Id;
272 Prefix_String : String_Id;
273 Typ : constant Entity_Id := Etype (N);
276 Ety := Entity (Prefix (N));
278 -- In case prefix is not a library unit entity, get the entity
281 while (Present (Scope (Ety))
282 and then Scope (Ety) /= Standard_Standard)
283 and not Is_Child_Unit (Ety)
288 -- Retrieve the proper function to call.
290 if Is_Remote_Call_Interface (Ety) then
291 Get_Pt_Id := New_Occurrence_Of
292 (RTE (RE_Get_Active_Partition_Id), Loc);
294 elsif Is_Shared_Passive (Ety) then
295 Get_Pt_Id := New_Occurrence_Of
296 (RTE (RE_Get_Passive_Partition_Id), Loc);
299 Get_Pt_Id := New_Occurrence_Of
300 (RTE (RE_Get_Local_Partition_Id), Loc);
303 -- Get and store the String_Id corresponding to the name of the
304 -- library unit whose Partition_Id is needed.
306 Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
307 Prefix_String := String_From_Name_Buffer;
309 -- Build the function call which will replace the attribute
311 if Is_Remote_Call_Interface (Ety)
312 or else Is_Shared_Passive (Ety)
315 Make_Function_Call (Loc,
317 Parameter_Associations =>
318 New_List (Make_String_Literal (Loc, Prefix_String)));
321 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
325 -- Replace the attribute node by a conversion of the function call
326 -- to the target type.
328 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
329 Analyze_And_Resolve (N, Typ);
330 end Process_Partition_Id;
332 ----------------------------------
333 -- Process_Remote_AST_Attribute --
334 ----------------------------------
336 procedure Process_Remote_AST_Attribute
338 New_Type : Entity_Id)
340 Loc : constant Source_Ptr := Sloc (N);
341 Remote_Subp : Entity_Id;
342 Tick_Access_Conv_Call : Node_Id;
343 Remote_Subp_Decl : Node_Id;
344 RS_Pkg_Specif : Node_Id;
345 RS_Pkg_E : Entity_Id;
346 RAS_Type : Entity_Id := New_Type;
348 All_Calls_Remote_E : Entity_Id;
349 Attribute_Subp : Entity_Id;
352 -- Check if we have to expand the access attribute
354 Remote_Subp := Entity (Prefix (N));
356 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
360 if Ekind (RAS_Type) /= E_Record_Type then
361 RAS_Type := Equivalent_Type (RAS_Type);
364 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
365 pragma Assert (Present (Attribute_Subp));
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);
377 Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
378 and then Is_Asynchronous (Remote_Subp));
380 All_Calls_Remote_E :=
381 Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
383 Tick_Access_Conv_Call :=
384 Make_Function_Call (Loc,
385 Name => New_Occurrence_Of (Attribute_Subp, Loc),
386 Parameter_Associations =>
388 Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
389 Build_Subprogram_Id (Loc, Remote_Subp),
390 New_Occurrence_Of (Async_E, Loc),
391 New_Occurrence_Of (All_Calls_Remote_E, Loc)));
393 Rewrite (N, Tick_Access_Conv_Call);
394 Analyze_And_Resolve (N, RAS_Type);
395 end Process_Remote_AST_Attribute;
397 ------------------------------------
398 -- Process_Remote_AST_Declaration --
399 ------------------------------------
401 procedure Process_Remote_AST_Declaration (N : Node_Id) is
402 Loc : constant Source_Ptr := Sloc (N);
403 User_Type : constant Node_Id := Defining_Identifier (N);
404 Scop : constant Entity_Id := Scope (User_Type);
405 Is_RCI : constant Boolean :=
406 Is_Remote_Call_Interface (Scop);
407 Is_RT : constant Boolean :=
408 Is_Remote_Types (Scop);
409 Type_Def : constant Node_Id := Type_Definition (N);
412 Is_Degenerate : Boolean;
413 -- True iff this RAS has an access formal parameter (see
414 -- Exp_Dist.Add_RAS_Dereference_TSS for details).
416 Subpkg : constant Entity_Id :=
417 Make_Defining_Identifier
418 (Loc, New_Internal_Name ('S'));
419 Subpkg_Decl : Node_Id;
420 Vis_Decls : constant List_Id := New_List;
421 Priv_Decls : constant List_Id := New_List;
423 Obj_Type : constant Entity_Id :=
424 Make_Defining_Identifier
425 (Loc, New_External_Name (
426 Chars (User_Type), 'R'));
428 Full_Obj_Type : constant Entity_Id :=
429 Make_Defining_Identifier
430 (Loc, Chars (Obj_Type));
432 RACW_Type : constant Entity_Id :=
433 Make_Defining_Identifier
434 (Loc, New_External_Name (
435 Chars (User_Type), 'P'));
437 Fat_Type : constant Entity_Id :=
438 Make_Defining_Identifier
439 (Loc, Chars (User_Type));
440 Fat_Type_Decl : Node_Id;
443 Is_Degenerate := False;
444 Parameter := First (Parameter_Specifications (Type_Def));
445 while Present (Parameter) loop
446 if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
447 Error_Msg_N ("formal parameter& has anonymous access type?",
448 Defining_Identifier (Parameter));
449 Is_Degenerate := True;
456 if Is_Degenerate then
458 "remote access-to-subprogram type& can only be null?",
459 Defining_Identifier (Parameter), User_Type);
460 -- The only legal value for a RAS with a formal parameter of an
461 -- anonymous access type is null, because it cannot be
462 -- subtype-Conformant with any legal remote subprogram declaration.
463 -- In this case, we cannot generate a corresponding primitive
467 if Get_PCS_Name = Name_No_DSA then
471 -- The tagged private type, primitive operation and RACW
472 -- type associated with a RAS need to all be declared in
473 -- a subpackage of the one that contains the RAS declaration,
474 -- because the primitive of the object type, and the associated
475 -- primitive of the stub type, need to be dispatching operations
476 -- of these types, and the profile of the RAS might contain
477 -- tagged types declared in the same scope.
479 Append_To (Vis_Decls,
480 Make_Private_Type_Declaration (Loc,
481 Defining_Identifier => Obj_Type,
482 Abstract_Present => True,
483 Tagged_Present => True,
484 Limited_Present => True));
486 Append_To (Priv_Decls,
487 Make_Full_Type_Declaration (Loc,
488 Defining_Identifier =>
491 Make_Record_Definition (Loc,
492 Abstract_Present => True,
493 Tagged_Present => True,
494 Limited_Present => True,
495 Null_Present => True,
496 Component_List => Empty)));
498 if not Is_Degenerate then
499 Append_To (Vis_Decls,
500 Make_Abstract_Subprogram_Declaration (Loc,
501 Specification => Build_RAS_Primitive_Specification (
502 Subp_Spec => Type_Def,
503 Remote_Object_Type => Obj_Type)));
506 Append_To (Vis_Decls,
507 Make_Full_Type_Declaration (Loc,
508 Defining_Identifier => RACW_Type,
510 Make_Access_To_Object_Definition (Loc,
512 Subtype_Indication =>
513 Make_Attribute_Reference (Loc,
515 New_Occurrence_Of (Obj_Type, Loc),
518 Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
519 Set_Is_Remote_Types (RACW_Type, Is_RT);
522 Make_Package_Declaration (Loc,
523 Make_Package_Specification (Loc,
524 Defining_Unit_Name =>
526 Visible_Declarations =>
528 Private_Declarations =>
531 New_Occurrence_Of (Subpkg, Loc)));
532 Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
533 Set_Is_Remote_Types (Subpkg, Is_RT);
534 Insert_After_And_Analyze (N, Subpkg_Decl);
536 -- Many parts of the analyzer and expander expect
537 -- that the fat pointer type used to implement remote
538 -- access to subprogram types be a record.
539 -- Note: The structure of this type must be kept consistent
540 -- with the code generated by Remote_AST_Null_Value for the
541 -- corresponding 'null' expression.
543 Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
544 Defining_Identifier => Fat_Type,
546 Make_Record_Definition (Loc,
548 Make_Component_List (Loc,
549 Component_Items => New_List (
550 Make_Component_Declaration (Loc,
551 Defining_Identifier =>
552 Make_Defining_Identifier (Loc, Name_Ras),
553 Component_Definition =>
554 Make_Component_Definition (Loc,
557 Subtype_Indication =>
558 New_Occurrence_Of (RACW_Type, Loc)))))));
559 Set_Equivalent_Type (User_Type, Fat_Type);
560 Set_Corresponding_Remote_Type (Fat_Type, User_Type);
561 Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
563 -- The reason we suppress the initialization procedure is that we know
564 -- that no initialization is required (even if Initialize_Scalars mode
565 -- is active), and there are order of elaboration problems if we do try
566 -- to generate an init proc for this created record type.
568 Set_Suppress_Init_Proc (Fat_Type);
570 if Expander_Active then
571 Add_RAST_Features (Parent (User_Type));
573 end Process_Remote_AST_Declaration;
575 -----------------------
576 -- RAS_E_Dereference --
577 -----------------------
579 procedure RAS_E_Dereference (Pref : Node_Id) is
580 Loc : constant Source_Ptr := Sloc (Pref);
582 New_Type : constant Entity_Id := Etype (Pref);
583 Explicit_Deref : constant Node_Id := Parent (Pref);
584 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
585 Deref_Proc : Entity_Id;
589 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
590 Params := Parameter_Associations (Deref_Subp_Call);
592 if Present (Params) then
593 Prepend (Pref, Params);
595 Params := New_List (Pref);
598 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
600 Params := Expressions (Deref_Subp_Call);
602 if Present (Params) then
603 Prepend (Pref, Params);
605 Params := New_List (Pref);
609 -- Context is not a call.
614 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
618 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
619 pragma Assert (Present (Deref_Proc));
621 if Ekind (Deref_Proc) = E_Function then
623 Make_Function_Call (Loc,
624 Name => New_Occurrence_Of (Deref_Proc, Loc),
625 Parameter_Associations => Params);
629 Make_Procedure_Call_Statement (Loc,
630 Name => New_Occurrence_Of (Deref_Proc, Loc),
631 Parameter_Associations => Params);
634 Rewrite (Deref_Subp_Call, Call_Node);
635 Analyze (Deref_Subp_Call);
636 end RAS_E_Dereference;
638 ------------------------------
639 -- Remote_AST_E_Dereference --
640 ------------------------------
642 function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
643 ET : constant Entity_Id := Etype (P);
646 -- Perform the changes only on original dereferences, and only if
647 -- we are generating code.
649 if Comes_From_Source (P)
650 and then Is_Record_Type (ET)
651 and then (Is_Remote_Call_Interface (ET)
652 or else Is_Remote_Types (ET))
653 and then Present (Corresponding_Remote_Type (ET))
654 and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
655 or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
656 and then Expander_Active
658 RAS_E_Dereference (P);
663 end Remote_AST_E_Dereference;
665 ------------------------------
666 -- Remote_AST_I_Dereference --
667 ------------------------------
669 function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
670 ET : constant Entity_Id := Etype (P);
674 if Comes_From_Source (P)
675 and then (Is_Remote_Call_Interface (ET)
676 or else Is_Remote_Types (ET))
677 and then Present (Corresponding_Remote_Type (ET))
678 and then Ekind (Entity (P)) /= E_Function
681 Make_Explicit_Dereference (Sloc (P),
682 Prefix => Relocate_Node (P));
685 RAS_E_Dereference (Prefix (P));
690 end Remote_AST_I_Dereference;
692 ---------------------------
693 -- Remote_AST_Null_Value --
694 ---------------------------
696 function Remote_AST_Null_Value
698 Typ : Entity_Id) return Boolean
700 Loc : constant Source_Ptr := Sloc (N);
701 Target_Type : Entity_Id;
704 if not Expander_Active or else Get_PCS_Name = Name_No_DSA then
707 elsif Ekind (Typ) = E_Access_Subprogram_Type
708 and then (Is_Remote_Call_Interface (Typ)
709 or else Is_Remote_Types (Typ))
710 and then Comes_From_Source (N)
711 and then Expander_Active
713 -- Any null that comes from source and is of the RAS type must
714 -- be expanded, except if expansion is not active (nothing
715 -- gets expanded into the equivalent record type).
717 Target_Type := Equivalent_Type (Typ);
719 elsif Ekind (Typ) = E_Record_Type
720 and then Present (Corresponding_Remote_Type (Typ))
722 -- This is a record type representing a RAS type, this must be
728 -- We do not have to handle this case
736 Component_Associations => New_List (
737 Make_Component_Association (Loc,
738 Choices => New_List (
739 Make_Identifier (Loc, Name_Ras)),
742 Analyze_And_Resolve (N, Target_Type);
744 end Remote_AST_Null_Value;