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;
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 -- Is_All_Remote_Call --
156 ------------------------
158 function Is_All_Remote_Call (N : Node_Id) return Boolean is
162 if (Nkind (N) = N_Function_Call
163 or else Nkind (N) = N_Procedure_Call_Statement)
164 and then Nkind (Name (N)) in N_Has_Entity
165 and then Is_Remote_Call_Interface (Entity (Name (N)))
166 and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
167 and then Comes_From_Source (N)
169 Par := Parent (Entity (Name (N)));
172 and then (Nkind (Par) /= N_Package_Specification
173 or else Is_Wrapper_Package (Defining_Entity (Par)))
178 if Present (Par) then
180 not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
187 end Is_All_Remote_Call;
189 ------------------------------------
190 -- Package_Specification_Of_Scope --
191 ------------------------------------
193 function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
194 N : Node_Id := Parent (E);
196 while Nkind (N) /= N_Package_Specification loop
201 end Package_Specification_Of_Scope;
203 --------------------------
204 -- Process_Partition_ID --
205 --------------------------
207 procedure Process_Partition_Id (N : Node_Id) is
208 Loc : constant Source_Ptr := Sloc (N);
211 Get_Pt_Id_Call : Node_Id;
212 Prefix_String : String_Id;
213 Typ : constant Entity_Id := Etype (N);
216 Ety := Entity (Prefix (N));
218 -- In case prefix is not a library unit entity, get the entity
221 while (Present (Scope (Ety))
222 and then Scope (Ety) /= Standard_Standard)
223 and not Is_Child_Unit (Ety)
228 -- Retrieve the proper function to call.
230 if Is_Remote_Call_Interface (Ety) then
231 Get_Pt_Id := New_Occurrence_Of
232 (RTE (RE_Get_Active_Partition_Id), Loc);
234 elsif Is_Shared_Passive (Ety) then
235 Get_Pt_Id := New_Occurrence_Of
236 (RTE (RE_Get_Passive_Partition_Id), Loc);
239 Get_Pt_Id := New_Occurrence_Of
240 (RTE (RE_Get_Local_Partition_Id), Loc);
243 -- Get and store the String_Id corresponding to the name of the
244 -- library unit whose Partition_Id is needed
246 Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety)));
248 -- Remove seven last character ("(spec)" or " (body)").
249 -- (this is a bit nasty, should have interface for this ???)
251 Name_Len := Name_Len - 7;
254 Store_String_Chars (Name_Buffer (1 .. Name_Len));
255 Prefix_String := End_String;
257 -- Build the function call which will replace the attribute
259 if Is_Remote_Call_Interface (Ety)
260 or else Is_Shared_Passive (Ety)
263 Make_Function_Call (Loc,
265 Parameter_Associations =>
266 New_List (Make_String_Literal (Loc, Prefix_String)));
269 Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
273 -- Replace the attribute node by a conversion of the function call
274 -- to the target type.
276 Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
277 Analyze_And_Resolve (N, Typ);
278 end Process_Partition_Id;
280 ----------------------------------
281 -- Process_Remote_AST_Attribute --
282 ----------------------------------
284 procedure Process_Remote_AST_Attribute
286 New_Type : Entity_Id)
288 Loc : constant Source_Ptr := Sloc (N);
289 Remote_Subp : Entity_Id;
290 Tick_Access_Conv_Call : Node_Id;
291 Remote_Subp_Decl : Node_Id;
292 RS_Pkg_Specif : Node_Id;
293 RS_Pkg_E : Entity_Id;
294 RAS_Type : Entity_Id;
296 Attribute_Subp : Entity_Id;
300 -- Check if we have to expand the access attribute
302 Remote_Subp := Entity (Prefix (N));
304 if not Expander_Active then
307 elsif Ekind (New_Type) = E_Record_Type then
308 RAS_Type := New_Type;
311 -- If the remote type has not been constructed yet, create
312 -- it and its attributes now.
314 Attribute_Subp := TSS (New_Type, TSS_RAS_Access);
316 if No (Attribute_Subp) then
317 Add_RAST_Features (Parent (New_Type));
320 RAS_Type := Equivalent_Type (New_Type);
323 Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
324 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
326 if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
327 Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
328 Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
331 RS_Pkg_Specif := Parent (Remote_Subp_Decl);
332 RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
334 if Ekind (Remote_Subp) = E_Procedure
335 and then Is_Asynchronous (Remote_Subp)
337 Async_E := Standard_True;
339 Async_E := Standard_False;
342 Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
344 Tick_Access_Conv_Call :=
345 Make_Function_Call (Loc,
346 Name => New_Occurrence_Of (Attribute_Subp, Loc),
347 Parameter_Associations =>
350 Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
351 Build_Subprogram_Id (Loc, Remote_Subp),
352 New_Occurrence_Of (Async_E, Loc)));
354 Rewrite (N, Tick_Access_Conv_Call);
355 Analyze_And_Resolve (N, RAS_Type);
356 end Process_Remote_AST_Attribute;
358 ------------------------------------
359 -- Process_Remote_AST_Declaration --
360 ------------------------------------
362 procedure Process_Remote_AST_Declaration (N : Node_Id) is
363 Loc : constant Source_Ptr := Sloc (N);
364 User_Type : constant Node_Id := Defining_Identifier (N);
365 Fat_Type : constant Entity_Id :=
366 Make_Defining_Identifier
367 (Loc, Chars (User_Type));
368 New_Type_Decl : Node_Id;
371 -- We add a record type declaration for the equivalent fat pointer type
374 Make_Full_Type_Declaration (Loc,
375 Defining_Identifier => Fat_Type,
377 Make_Record_Definition (Loc,
379 Make_Component_List (Loc,
380 Component_Items => New_List (
382 Make_Component_Declaration (Loc,
383 Defining_Identifier =>
384 Make_Defining_Identifier (Loc,
386 Component_Definition =>
387 Make_Component_Definition (Loc,
388 Aliased_Present => False,
389 Subtype_Indication =>
390 New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
392 Make_Component_Declaration (Loc,
393 Defining_Identifier =>
394 Make_Defining_Identifier (Loc,
395 Chars => Name_Origin),
396 Component_Definition =>
397 Make_Component_Definition (Loc,
398 Aliased_Present => False,
399 Subtype_Indication =>
400 New_Reference_To (Standard_Integer, Loc))),
402 Make_Component_Declaration (Loc,
403 Defining_Identifier =>
404 Make_Defining_Identifier (Loc,
405 Chars => Name_Receiver),
406 Component_Definition =>
407 Make_Component_Definition (Loc,
408 Aliased_Present => False,
409 Subtype_Indication =>
410 New_Reference_To (RTE (RE_Unsigned_64), Loc))),
412 Make_Component_Declaration (Loc,
413 Defining_Identifier =>
414 Make_Defining_Identifier (Loc,
415 Chars => Name_Subp_Id),
416 Component_Definition =>
417 Make_Component_Definition (Loc,
418 Aliased_Present => False,
419 Subtype_Indication =>
420 New_Reference_To (Standard_Natural, Loc))),
422 Make_Component_Declaration (Loc,
423 Defining_Identifier =>
424 Make_Defining_Identifier (Loc,
425 Chars => Name_Async),
426 Component_Definition =>
427 Make_Component_Definition (Loc,
428 Aliased_Present => False,
429 Subtype_Indication =>
430 New_Reference_To (Standard_Boolean, Loc)))))));
432 Insert_After (N, New_Type_Decl);
433 Set_Equivalent_Type (User_Type, Fat_Type);
434 Set_Corresponding_Remote_Type (Fat_Type, User_Type);
436 -- The reason we suppress the initialization procedure is that we know
437 -- that no initialization is required (even if Initialize_Scalars mode
438 -- is active), and there are order of elaboration problems if we do try
439 -- to generate an init proc for this created record type.
441 Set_Suppress_Init_Proc (Fat_Type);
443 if Expander_Active then
444 Add_RAST_Features (Parent (User_Type));
446 end Process_Remote_AST_Declaration;
448 -----------------------
449 -- RAS_E_Dereference --
450 -----------------------
452 procedure RAS_E_Dereference (Pref : Node_Id) is
453 Loc : constant Source_Ptr := Sloc (Pref);
455 New_Type : constant Entity_Id := Etype (Pref);
456 RAS : constant Entity_Id :=
457 Corresponding_Remote_Type (New_Type);
458 RAS_Decl : constant Node_Id := Parent (RAS);
459 Explicit_Deref : constant Node_Id := Parent (Pref);
460 Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
461 Deref_Proc : Entity_Id;
465 if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
466 Params := Parameter_Associations (Deref_Subp_Call);
468 if Present (Params) then
469 Prepend (Pref, Params);
471 Params := New_List (Pref);
474 elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
476 Params := Expressions (Deref_Subp_Call);
478 if Present (Params) then
479 Prepend (Pref, Params);
481 Params := New_List (Pref);
485 -- Context is not a call.
490 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
492 if not Expander_Active then
495 elsif No (Deref_Proc) then
496 Add_RAST_Features (RAS_Decl);
497 Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
500 if Ekind (Deref_Proc) = E_Function then
502 Make_Function_Call (Loc,
503 Name => New_Occurrence_Of (Deref_Proc, Loc),
504 Parameter_Associations => Params);
508 Make_Procedure_Call_Statement (Loc,
509 Name => New_Occurrence_Of (Deref_Proc, Loc),
510 Parameter_Associations => Params);
513 Rewrite (Deref_Subp_Call, Call_Node);
514 Analyze (Deref_Subp_Call);
515 end RAS_E_Dereference;
517 ------------------------------
518 -- Remote_AST_E_Dereference --
519 ------------------------------
521 function Remote_AST_E_Dereference (P : Node_Id) return Boolean
523 ET : constant Entity_Id := Etype (P);
526 -- Perform the changes only on original dereferences, and only if
527 -- we are generating code.
529 if Comes_From_Source (P)
530 and then Is_Record_Type (ET)
531 and then (Is_Remote_Call_Interface (ET)
532 or else Is_Remote_Types (ET))
533 and then Present (Corresponding_Remote_Type (ET))
534 and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
535 or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
536 and then Expander_Active
538 RAS_E_Dereference (P);
543 end Remote_AST_E_Dereference;
545 ------------------------------
546 -- Remote_AST_I_Dereference --
547 ------------------------------
549 function Remote_AST_I_Dereference (P : Node_Id) return Boolean
551 ET : constant Entity_Id := Etype (P);
555 if Comes_From_Source (P)
556 and then (Is_Remote_Call_Interface (ET)
557 or else Is_Remote_Types (ET))
558 and then Present (Corresponding_Remote_Type (ET))
559 and then Ekind (Entity (P)) /= E_Function
562 Make_Explicit_Dereference (Sloc (P),
563 Prefix => Relocate_Node (P));
566 RAS_E_Dereference (Prefix (P));
571 end Remote_AST_I_Dereference;
573 ---------------------------
574 -- Remote_AST_Null_Value --
575 ---------------------------
577 function Remote_AST_Null_Value
582 Loc : constant Source_Ptr := Sloc (N);
583 Target_Type : Entity_Id;
586 if not Expander_Active then
589 elsif Ekind (Typ) = E_Access_Subprogram_Type
590 and then (Is_Remote_Call_Interface (Typ)
591 or else Is_Remote_Types (Typ))
592 and then Comes_From_Source (N)
593 and then Expander_Active
595 -- Any null that comes from source and is of the RAS type must
596 -- be expanded, except if expansion is not active (nothing
597 -- gets expanded into the equivalent record type).
599 Target_Type := Equivalent_Type (Typ);
601 elsif Ekind (Typ) = E_Record_Type
602 and then Present (Corresponding_Remote_Type (Typ))
604 -- This is a record type representing a RAS type, this must be
610 -- We do not have to handle this case
618 Expressions => New_List (
619 Make_Integer_Literal (Loc, 0), -- Ras
620 Make_Integer_Literal (Loc, 0), -- Origin
621 Make_Integer_Literal (Loc, 0), -- Receiver
622 Make_Integer_Literal (Loc, 0), -- Subp_Id
623 New_Occurrence_Of (Standard_False, Loc)))); -- Asyn
624 Analyze_And_Resolve (N, Target_Type);
626 end Remote_AST_Null_Value;