Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / sem_dist.adb < prev next >

Wrap

Text File | 1996-09-28 | 117KB | 3,530 lines

------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ D I S T -- -- -- -- B o d y -- -- -- -- $Revision: 1.80 $ -- -- -- -- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 2, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING. If not, write -- -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Errout; use Errout; with Elists; use Elists; with Exp_Dist; use Exp_Dist; with Lib; use Lib; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; with Osint; use Osint; with Opt; use Opt; with Sem; use Sem; with Sem_Ch7; use Sem_Ch7; with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Sprint; use Sprint; with Stand; use Stand; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Dist is ----------------------- -- Local Subprograms -- ----------------------- procedure Check_Categorization_Dependencies (Unit_Entity : Entity_Id; Depended_Entity : Entity_Id; Info_Node : Node_Id); -- This procedure checks that the categorization of a lib unit and that -- of the depended unit satisfy dependency restrictions. -- What is the info-Node param, need more documentation ??? procedure Check_Non_Static_Default_Expr (L : List_Id); -- Iterate through the component list of a record definition, check -- that no component is declared with a non-static default value. function Get_Name_Id (Name : String) return Name_Id; -- Given a string, return the Name_Id that represent the string function Has_Pragma_All_Calls_Remote (L : List_Id) return Boolean; -- Return true if L contains a pragma All_Calls_Remote node. function Static_Discriminant_Expr (L : List_Id) return Boolean; -- Iterate through the list of discriminants to check if any of them -- contains non-static default expression, which is a violation in -- a preelaborated library unit. ------------------------ -- Append_System_RPC -- ------------------------ procedure Append_System_RPC (N : Node_Id) is Decls : constant List_Id := Visible_Declarations (Specification (Unit (N))); S : constant Source_Ptr := Sloc (N); Items : List_Id := Context_Items (N); F : List_Id := Following_Pragmas (N); Decl : Node_Id; Item : Node_Id; procedure Appends (N : in out Node_Id); -- Given N, first node in a list (visible declarations or following -- pragmas) append to the list context items "with System.Rpc" if -- unit is either RCI or remote types. procedure Appends (N : in out Node_Id) is begin while Present (N) and then Nkind (N) = N_Pragma loop if Chars (N) = Name_Remote_Call_Interface or else Chars (N) = Name_Remote_Types then Item := Make_With_Clause (S, Make_Selected_Component (S, Prefix => Make_Identifier (S, Name_System), Selector_Name => Make_Identifier (S, Name_Rpc))); if Present (Items) then Append (Item, Items); else Items := New_List; Append (Item, Items); end if; end if; N := Next (N); end loop; end Appends; -- Start processing of Append_System_Rpc begin if not Present (Decls) then return; end if; Decl := First (Decls); Appends (Decl); if not Present (F) then return; end if; Decl := First (F); Appends (Decl); end Append_System_RPC; -------------------------- -- Append_System_RPC_PI -- -------------------------- procedure Append_System_RPC_PI (N : Node_Id; L : Node_Id) is Loc : constant Source_Ptr := Sloc (N); procedure Appends (Items : List_Id); -- Given Items, a list of visible declarations or following pragmas -- of L, append System.Rpc.Partition_Interface to the context items -- of N if any of there is Remote_Call_Interface or Remote_Types -- pragma in the list. procedure Appends (Items : List_Id) is Nd : Node_Id; begin if Present (Items) then Nd := First (Items); while Present (Nd) loop -- Search ends when non-pragma is met since they appear first exit when Nkind (Nd) /= N_Pragma; if Chars (Nd) = Name_Remote_Call_Interface or else Chars (Nd) = Name_Remote_Types then Append_To (Context_Items (N), Make_With_Clause (Loc, Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Partition_Interface)))); end if; Nd := Next (Nd); end loop; end if; end Appends; -- Start processing of Append_System_Rpc_PI begin if Nkind (Unit (L)) = N_Package_Declaration then Appends (Visible_Declarations (Specification (Unit (L)))); Appends (Following_Pragmas (L)); end if; end Append_System_RPC_PI; --------------------------------------- -- Check_Categorization_Dependencies -- --------------------------------------- procedure Check_Categorization_Dependencies (Unit_Entity : Entity_Id; Depended_Entity : Entity_Id; Info_Node : Node_Id) is N : Node_Id := Info_Node; Depended_Unit_Node : Node_Id; begin if Nkind (Info_Node) = N_With_Clause then -- Compilation unit node of withed unit. Depended_Unit_Node := Library_Unit (Info_Node); else -- Parent spec compilation unit node. Depended_Unit_Node := Info_Node; end if; if Is_Preelaborated (Unit_Entity) and then not Is_Preelaborated (Depended_Entity) and then not Is_Remote_Call_Interface (Depended_Entity) and then not Is_Remote_Types (Depended_Entity) and then not Is_Shared_Passive (Depended_Entity) and then not Is_Pure (Depended_Entity) then Error_Msg_N ("preelaborated unit dependency violation", N); elsif Is_Pure (Unit_Entity) and then not Is_Pure (Depended_Entity) then Error_Msg_N ("pure unit dependency violation", N); elsif Is_Shared_Passive (Unit_Entity) and then (not Is_Shared_Passive (Depended_Entity) and not Is_Pure (Depended_Entity)) then Error_Msg_N ("shared passive unit dependency violation", N); elsif Is_Remote_Types (Unit_Entity) and then not Is_Remote_Types (Depended_Entity) and then not Is_Shared_Passive (Depended_Entity) and then not Is_Pure (Depended_Entity) then -- System.Rpc is withed in processing remote access to subprogram -- type by RCI and remote types units to generate fat pointer type. -- Since System.Rpc is not categorized (not an error, by the way), -- there will be a dependency violation if we don't skip checking -- at this point. if Chars (Depended_Entity) = Name_Rpc and then Present (Scope (Depended_Entity)) and then Chars (Scope (Depended_Entity)) = Name_System then return; end if; Error_Msg_N ("remote_types unit dependency violation", N); elsif Is_Remote_Call_Interface (Unit_Entity) and then not Is_Remote_Call_Interface (Depended_Entity) and then not Is_Remote_Types (Depended_Entity) and then not Is_Shared_Passive (Depended_Entity) and then not Is_Pure (Depended_Entity) then -- System.Rpc is withed in processing remote access to subprogram -- type by RCI and remote types units to generate fat pointer type. -- Since System.Rpc is not categorized (not an error, by the way), -- there will be a dependency violation if we don't skip checking -- at this point. if Chars (Depended_Entity) = Name_Rpc and then Present (Scope (Depended_Entity)) and then Chars (Scope (Depended_Entity)) = Name_System then return; end if; Error_Msg_N ("remote call interface unit dependency violation", N); end if; end Check_Categorization_Dependencies; ----------------------------------- -- Check_Non_Static_Default_Expr -- ----------------------------------- procedure Check_Non_Static_Default_Expr (L : List_Id) is Component_Decl : Node_Id; begin -- Check against that component declarations does not involve -- ******* above line is incomprehensible ??? ******** -- a. a non-static default expression, where the object is -- declared to be default initialized. -- b. a dynamic Itype (discriminants and constraints) Component_Decl := First (L); while Present (Component_Decl) and then Nkind (Component_Decl) = N_Component_Declaration loop if Present (Expression (Component_Decl)) and then not Is_Static_Expression (Expression (Component_Decl)) then Error_Msg_N ("non-static expression in declaration in preelaborated unit", Component_Decl); elsif Has_Dynamic_Itype (Component_Decl) then Error_Msg_N ("dynamic type discriminant, constraint in preelaborated unit", Component_Decl); end if; Component_Decl := Next (Component_Decl); end loop; end Check_Non_Static_Default_Expr; -------------------------------------- -- CW_Remote_Extension_Add_Receiver -- -------------------------------------- procedure CW_Remote_Extension_Add_Receiver (N : Node_Id) is PN : constant Node_Id := Parent (N); LU : Node_Id; PD : Node_Id; SP : Node_Id; BL : List_Id; LN : Node_Id; procedure Add_Receiver (L : List_Id); -- In case there is a classwide type remote extension (check spec -- for definition) on the list, append a receiver for such type -- (extension) procedure Add_Receiver (L : List_Id) is Decl : Node_Id; begin if not Present (L) then return; end if; Decl := First (L); while Present (Decl) loop if Is_Class_Wide_Type_Remote_Extension (Decl) then if not Is_Remote_Call_Interface (Defining_Identifier (Decl)) then -- Add to BL (package body declaration list) the -- receiver subprogram for the type (extension) null; -- ??? To be updated soon end if; end if; Decl := Next (Decl); end loop; end Add_Receiver; -- Start of processing CW_Remote_Extension_Add_Receiver begin if Nkind (PN) /= N_Compilation_Unit then return; end if; LU := Library_Unit (PN); if not Present (LU) then return; end if; PD := Unit (LU); if Nkind (PD) /= N_Package_Declaration then return; end if; SP := Specification (PD); BL := Declarations (N); LN := Last (BL); Add_Receiver (Visible_Declarations (SP)); Add_Receiver (Private_Declarations (SP)); Add_Receiver (BL); end CW_Remote_Extension_Add_Receiver; ------------------------------- -- Enclosing_Lib_Unit_Entity -- ------------------------------- function Enclosing_Lib_Unit_Entity return Entity_Id is Unit_Entity : Entity_Id := Current_Scope; begin -- Look for enclosing library unit entity by following scope links. -- Equivalent to, but faster than indexing through the scope stack. while (Present (Scope (Unit_Entity)) and then Scope (Unit_Entity) /= Standard_Standard) and not Is_Child_Unit (Unit_Entity) loop Unit_Entity := Scope (Unit_Entity); end loop; return Unit_Entity; end Enclosing_Lib_Unit_Entity; ----------------------------- -- Enclosing_Lib_Unit_Node -- ----------------------------- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is Current_Node : Node_Id := N; begin while Present (Current_Node) and then Nkind (Current_Node) /= N_Compilation_Unit loop Current_Node := Parent (Current_Node); end loop; if Nkind (Current_Node) /= N_Compilation_Unit then return Empty; end if; return Current_Node; end Enclosing_Lib_Unit_Node; -------------------------- -- Generate_Stubs_Files -- -------------------------- procedure Generate_Stubs_Files (N : Node_Id) is Unit_Node : Node_Id := Unit (N); Copy : Node_Id; CB : Node_Id := Empty; SS : Node_Id := Empty; SB : Node_Id := Empty; procedure Output_Stubs_File (Stubs_Node : Node_Id); -- Create the source file for a stubs node procedure Output_Stubs_File (Stubs_Node : Node_Id) is begin Stub_Output_Start; Sprint_Node_Pure_Ada (Stubs_Node); Stub_Output_Stop; end Output_Stubs_File; -- Start of processing for Generate_Stubs_Files begin if Stub_Mode = Generate_Caller_Stub_Body then if Nkind (Unit_Node) = N_Package_Declaration then Init_Names; Output_Stubs_File (Build_Calling_Stubs_Bodies_Cunit (N)); else Error_Msg_N ("Specification file expected from command line", Unit_Node); end if; elsif Stub_Mode = Generate_Receiver_Stub_Body then Init_Names; Output_Stubs_File (Build_Receiving_Stubs_Bodies_Cunit (N)); end if; end Generate_Stubs_Files; ----------------- -- Get_Name_Id -- ----------------- function Get_Name_Id (Name : String) return Name_Id is begin Name_Len := Name'Length; Name_Buffer (1 .. Name_Len) := Name; return Name_Find; end Get_Name_Id; --------------------------------- -- Has_Pragma_All_Calls_Remote -- --------------------------------- function Has_Pragma_All_Calls_Remote (L : List_Id) return Boolean is Decl : Node_Id; begin if Present (L) then Decl := First (L); while Present (Decl) and then (Nkind (Decl) /= N_Pragma or else Chars (Decl) /= Name_All_Calls_Remote) loop Decl := Next (Decl); end loop; if Present (Decl) then return True; end if; end if; return False; end Has_Pragma_All_Calls_Remote; ------------------------------- -- Inside_Preelaborated_Unit -- ------------------------------- function Inside_Preelaborated_Unit return Boolean is Unit_Entity : constant Entity_Id := Current_Scope; begin -- Body of RCI unit is unconstrained. -- Body of RCI subprogram is not tested here. -- Above comments are not clear to me ??? (RBKD) return Is_Preelaborated (Unit_Entity) or else Is_Pure (Unit_Entity) or else Is_Shared_Passive (Unit_Entity) or else Is_Remote_Types (Unit_Entity) or else (Is_Remote_Call_Interface (Unit_Entity) and then Nkind (Unit (Cunit (Current_Sem_Unit))) /= N_Package_Body); end Inside_Preelaborated_Unit; ---------------------- -- Inside_Pure_Unit -- ---------------------- function Inside_Pure_Unit return Boolean is begin return Is_Pure (Current_Scope); end Inside_Pure_Unit; --------------------------------------- -- Inside_Remote_Call_Interface_Unit -- --------------------------------------- function Inside_Remote_Call_Interface_Unit return Boolean is Unit_Entity : constant Entity_Id := Current_Scope; begin -- Body of RCI unit is unconstrained. -- Body of RCI subprogram is not tested here since there is no -- such thing as an RCI subprogram library unit. -- Above comments are unclear to me (RBKD) ??? return Is_Remote_Call_Interface (Unit_Entity) and then Nkind (Unit (Cunit (Current_Sem_Unit))) /= N_Package_Body; end Inside_Remote_Call_Interface_Unit; ----------------------------- -- Inside_Remote_Types_Unit -- ----------------------------- function Inside_Remote_Types_Unit return Boolean is Unit_Entity : constant Entity_Id := Current_Scope; begin -- Body of Remote Types unit is unconstrained (RM E.2(9)) return Is_Remote_Types (Unit_Entity) and then Nkind (Unit (Cunit (Current_Sem_Unit))) /= N_Package_Body; end Inside_Remote_Types_Unit; -------------------------------- -- Inside_Shared_Passive_Unit -- -------------------------------- function Inside_Shared_Passive_Unit return Boolean is Unit_Entity : constant Entity_Id := Current_Scope; begin return Is_Shared_Passive (Unit_Entity); end Inside_Shared_Passive_Unit; ------------------------------------------- -- Inside_Subprogram_Task_Protected_Unit -- ------------------------------------------- function Inside_Subprogram_Task_Protected_Unit return Boolean is E : Entity_Id; K : Entity_Kind; begin -- The following is to verify that a declaration is inside -- subprogram, generic subprogram, task unit, protected unit. -- Used to validate if a lib. unit is Pure. RM 10.2.1(16). -- Use scope chain to check successively outer scopes E := Current_Scope; loop K := Ekind (E); if K = E_Procedure or else K = E_Function or else K = E_Generic_Procedure or else K = E_Generic_Function or else K = E_Task_Type or else K = E_Task_Subtype or else K = E_Protected_Type or else K = E_Protected_Subtype then return True; elsif E = Standard_Standard then return False; end if; E := Scope (E); end loop; end Inside_Subprogram_Task_Protected_Unit; ---------------------------- -- Inside_Subprogram_Unit -- ---------------------------- function Inside_Subprogram_Unit return Boolean is E : Entity_Id; K : Entity_Kind; begin -- Use scope chain to check successively outer scopes E := Current_Scope; loop K := Ekind (E); if K = E_Procedure or else K = E_Function or else K = E_Generic_Procedure or else K = E_Generic_Function then return True; elsif E = Standard_Standard then return False; end if; E := Scope (E); end loop; end Inside_Subprogram_Unit; ----------------------------------------- -- Is_Class_Wide_Type_Remote_Extension -- ----------------------------------------- function Is_Class_Wide_Type_Remote_Extension (N : Node_Id) return Boolean is Derived : Entity_Id; Root_Ty : Entity_Id; Contexts : List_Id; Item : Node_Id; Item_Ety : Entity_Id; RACW : Entity_Id; DD : Node_Id; function Compare_Root_W_RACW (E : Entity_Id) return Boolean; -- Return True if the list containing input entity E has a -- remote access to classwide type and whose designated type is -- the root abstract type of the Derived type function Compare_Root_W_RACW (E : Entity_Id) return Boolean is Remote_Access : Entity_Id := E; begin while Present (Remote_Access) loop if Is_Remote_Access_To_Class_Wide_Type (Remote_Access) then DD := Directly_Designated_Type (Remote_Access); -- Test if the designated type of this Remote-Access-To- -- Classwide-type is the Root abstract type of the -- derived type. if Etype (DD) = Root_Ty then return True; end if; end if; Remote_Access := Next_Entity (Remote_Access); end loop; return False; end Compare_Root_W_RACW; begin if Nkind (N) /= N_Full_Type_Declaration then return False; end if; if Nkind (Type_Definition (N)) /= N_Derived_Type_Definition then return False; end if; Derived := Defining_Identifier (N); if not Is_Limited_Record (Derived) then return False; end if; if not Is_Tagged_Type (Derived) then return False; end if; Root_Ty := Etype (Derived); Contexts := Context_Items (Cunit (Current_Sem_Unit)); if not Present (Contexts) then return False; end if; Item := First (Contexts); while Present (Item) loop if Nkind (Item) = N_With_Clause then Item_Ety := Entity (Name (Item)); if Is_Remote_Call_Interface (Item_Ety) then RACW := First_Entity (Item_Ety); if Compare_Root_W_RACW (RACW) then return True; end if; end if; end if; Item := Next (Item); end loop; -- For compiler generated classwide extensions "object_stub" in -- an RCI unit (spec and body) if Is_Remote_Call_Interface (Derived) then RACW := First_Entity (Scope (Derived)); if Compare_Root_W_RACW (RACW) then return True; end if; end if; return False; end Is_Class_Wide_Type_Remote_Extension; ----------------------------------------- -- Is_Remote_Access_To_Class_Wide_Type -- ----------------------------------------- function Is_Remote_Access_To_Class_Wide_Type (E : Entity_Id) return Boolean is DD : Node_Id; ED : Node_Id; EE : Entity_Id; begin -- This type entity would have been set Is_Remote_Call_Interface -- during the type declaration in case it is inside an RCI unit. -- This type entity would have been set Is_Remote_Types during -- the type declaration in case it is inside a Remote_Types unit. if not Is_Remote_Call_Interface (E) and then not Is_Remote_Types (E) then return False; end if; if Ekind (E) = E_General_Access_Type then DD := Directly_Designated_Type (E); ED := Parent (Etype (DD)); if Nkind (ED) = N_Private_Type_Declaration and then Limited_Present (ED) and then Ekind (DD) = E_Class_Wide_Type then return True; end if; end if; return False; end Is_Remote_Access_To_Class_Wide_Type; ----------------------------------------- -- Is_Remote_Access_To_Subprogram_Type -- ----------------------------------------- function Is_Remote_Access_To_Subprogram_Type (E : Entity_Id) return Boolean is EE : Entity_Id; SE : Entity_Id; DD : Entity_Id; begin -- This type entity would have been set Is_Remote_Call_Interface -- during the type declaration in case it is inside an RCI unit. -- This type entity would have been set Is_Remote_Types during -- the type declaration in case it is inside a Remote_Types unit. if not Is_Remote_Call_Interface (E) and then not Is_Remote_Types (E) then return False; end if; if Ekind (E) = E_Access_Subprogram_Type then return True; end if; return False; end Is_Remote_Access_To_Subprogram_Type; ---------------------------------- -- Process_Remote_AST_Attribute -- ---------------------------------- procedure Process_Remote_AST_Attribute (N : Node_Id; UN : Node_Id) is PE : constant Entity_Id := Entity (Prefix (N)); S : constant Source_Ptr := Sloc (N); NN : Node_Id; N1 : Node_Id; Ex : List_Id := New_List; Nd : Node_Id; Nd1 : Node_Id; Nd2 : Node_Id; SS : Node_Id; NM : Name_Id; E1 : Entity_Id; E2 : Entity_Id; CL : List_Id; CT : Node_Id; function Compare_Params (L1 : List_Id; L2 : List_Id) return Boolean; -- Given L1, L2 two lists of parameters, return True if they match -- every parameter. function Compare_Params (L1 : List_Id; L2 : List_Id) return Boolean is N1 : Node_Id; N2 : Node_Id; E1 : Entity_Id; E2 : Entity_Id; begin if not Present (L1) and then not Present (L2) then return True; end if; if not Present (L1) or else not Present (L2) then return False; end if; N1 := First (L1); N2 := First (L2); while Present (N1) and then Present (N2) loop E1 := Etype (Defining_Identifier (N1)); E2 := Etype (Defining_Identifier (N2)); if E1 /= E2 then return False; end if; N1 := Next (N1); N2 := Next (N2); end loop; return True; end Compare_Params; function Get_Entity (S : Node_Id; L : List_Id) return Entity_Id; -- Search through L, the list of declarations to find a remote -- access to subprogram type declaration whose signature matches -- that of S, the procedure/function specification node of a remote -- subprogram. -- Return Empty if there is no match, return the entity of fat pointer -- type if there is a match. function Get_Entity (S : Node_Id; L : List_Id) return Entity_Id is EK : constant Entity_Kind := Ekind (PE); N : Node_Id; N1 : Node_Id; N2 : Node_Id; L1 : List_Id; L2 : List_Id; begin if not Present (L) then return Empty; end if; -- Search backwards N := Last (L); while Present (N) loop if Nkind (N) = N_Full_Type_Declaration then N1 := Type_Definition (N); if Nkind (N1) = N_Access_Procedure_Definition and then EK = E_Procedure then L1 := Parameter_Specifications (S); L2 := Parameter_Specifications (N1); if Compare_Params (L1, L2) then -- Return the defining identifier of the following -- fat pointer type declaration return Defining_Identifier (Next (N)); end if; elsif Nkind (N1) = N_Access_Function_Definition and then EK = E_Function and then Entity (Subtype_Mark (N1)) = Entity (Subtype_Mark (S)) then L1 := Parameter_Specifications (S); L2 := Parameter_Specifications (N1); if Compare_Params (L1, L2) then -- Return the defining identifier of the following -- fat pointer type declaration return Defining_Identifier (Next (N)); end if; end if; end if; N := Prev (N); end loop; return Empty; end Get_Entity; -- Start processing of Process_Remote_AST_Attribute begin -- Process only if this is a remote subprogram access attribute if not Is_Remote_Call_Interface (PE) and then not Is_Remote_Types (PE) then return; end if; -- In case prefix is remote subprogram then we intend to transform -- remore_subprogram_name'access into -- (package_name.remote_access_to_subprogram_typeR'access, -- remote_subprogram_name'access, -- system.rpc.partition_interface.get_local_partition_id -- True/False) -- Return if it is rewritten by this procedure already if Nkind (Parent (N)) = N_Component_Association or Nkind (Parent (N)) = N_Aggregate then return; end if; -- In order to construct the aggregate (it's first component), -- we need to find the remote access to subprogram type declaration -- that matches the signature of (this attribute reference) prefix -- remote_subprogram_name. -- Search through specification of this unit first. SS := Parent (PE); Nd := Enclosing_Lib_Unit_Node (N); E1 := Enclosing_Lib_Unit_Entity; CL := Context_Items (Nd); Nd1 := Unit (Nd); if Nkind (Nd1) = N_Package_Declaration and then (Is_Remote_Call_Interface (E1) or else Is_Remote_Types (E1)) then E2 := Get_Entity (SS, Visible_Declarations (Specification (Nd1))); if Present (E2) then N1 := Make_Attribute_Reference (S, Prefix => Make_Selected_Component (S, Prefix => Make_Identifier (S, Chars (E1)), Selector_Name => Make_Identifier (S, New_External_Name (Chars (E2), 'R', 0, ' '))), Attribute_Name => Name_Access); goto Found; end if; end if; -- Then search (body) of this unit if Nkind (Nd1) = N_Package_Body then E2 := Corresponding_Spec (Nd1); if Is_Remote_Call_Interface (E2) or else Is_Remote_Types (E2) then Nd2 := Parent (E2); E2 := Get_Entity (SS, Visible_Declarations (Nd2)); if Present (E2) then N1 := Make_Attribute_Reference (S, Prefix => Make_Selected_Component (S, Prefix => Make_Identifier (S, Chars (E1)), Selector_Name => Make_Identifier (S, New_External_Name (Chars (E2), 'R', 0, ' '))), Attribute_Name => Name_Access); goto Found; end if; end if; end if; -- Then search the withed unit (specification) CT := First (CL); while Present (CT) loop if Nkind (CT) = N_With_Clause and then Nkind (Unit (Library_Unit (CT))) = N_Package_Declaration then E2 := Entity (Name (CT)); E1 := E2; if Is_Remote_Call_Interface (E2) or else Is_Remote_Types (E2) then Nd2 := Parent (E2); E2 := Get_Entity (SS, Visible_Declarations (Nd2)); if Present (E2) then N1 := Make_Attribute_Reference (S, Prefix => Make_Selected_Component (S, Prefix => Make_Identifier (S, Chars (E1)), Selector_Name => Make_Identifier (S, New_External_Name (Chars (E2), 'R', 0, ' '))), Attribute_Name => Name_Access); goto Found; end if; end if; end if; CT := Next (CT); end loop; -- Now since we did not find such remote access to subprogram type -- we should not do the transformation. return; <<Found>> null; -- Now construct the third component of this aggregate -- system.rpc.partition_interface.get_local_partition_id E1 := Make_Selected_Component (S, Prefix => Make_Selected_Component (S, Prefix => Make_Selected_Component (S, Prefix => Make_Identifier (S, Name_System), Selector_Name => Make_Identifier (S, Name_Rpc)), Selector_Name => Make_Identifier (S, Name_Partition_Interface)), Selector_Name => Make_Identifier (S, Name_Get_Local_Partition_ID)); -- Now construct the fourth component of this aggregate -- True/False -- which represent if the subprogram is asynchronous. -- Do a search in the package that the remote subprogram is declared -- to check if there is a pragma asynchronous associated with it. Nd := Next (Parent (SS)); while Present (Nd) loop if Nkind (Nd) = N_Pragma and then Chars (Nd) = Name_Asynchronous then Nd1 := Expression (First (Pragma_Argument_Associations (Nd))); if Chars (Nd1) = Chars (PE) then Nd2 := Make_Identifier (S, Chars (Standard_True)); goto Found_Pragma; end if; end if; Nd := Next (Nd); end loop; Nd2 := Make_Identifier (S, Chars (Standard_False)); <<Found_Pragma>> null; -- Now build the aggregate and rewrite the attribute reference to -- the aggregate Append (N1, Ex); Append (UN, Ex); Append (E1, Ex); Append (Nd2, Ex); NN := Make_Aggregate (S, Ex); Analyze (NN); Rewrite_Substitute_Tree (N, NN); end Process_Remote_AST_Attribute; ------------------------------------ -- Process_Remote_AST_Declaration -- ------------------------------------ procedure Process_Remote_AST_Declaration (N : Node_Id) is Decls : constant List_Id := List_Containing (N); Defining_Id : constant Node_Id := Defining_Identifier (N); Old_Name : constant Name_Id := Chars (Defining_Id); New_Name : constant Name_Id := New_External_Name (Old_Name, 'A', 0, ' '); Sub_Name : constant Name_Id := New_External_Name (Old_Name, 'D', 0, ' '); Loc : constant Source_Ptr := Sloc (N); Record_Ty : Node_Id; NN : Node_Id; N1 : Node_Id; PL : List_Id; SM : Node_Id; PS : Node_Id; SD : Node_Id; Nd : Node_Id; Nd1 : Node_Id; DL : List_Id; DL2 : List_Id; SL : List_Id; Ori_Arg_List : List_Id; Arg_List : List_Id; Param_Type : Node_Id; Arg : Node_Id; Param : Node_Id; SP : Node_Id; Name1 : Name_Id; Name2 : Name_Id; Name3 : Name_Id; Name4 : Name_Id; Name5 : Name_Id; Name6 : Name_Id; Name7 : Name_Id; Name8 : Name_Id; Name9 : Name_Id; Name10 : Name_Id; L1 : List_Id := New_List; L2 : List_Id := New_List; L3 : List_Id := New_List; AST_RVR : Node_Id; Then_Stmts : List_Id := New_List; Else_Stmts : List_Id := New_List; Left_Opnd : Node_Id; Right_Opnd : Node_Id; Reraise_Nm : Name_Id; begin -- We transform a declaration of remote access to subprogram type: -- type oldname is access to procedure (arg : arg_type); -- into a similar declaration with new type name: -- type newname is access to procedure (arg : arg_type); -- and a record type declaration with the name of the original type -- type oldname is -- record -- ast_receiver : system.rpc.rpc_receiver; -- pointer : newname; -- pid : system.rpc.partition_id; -- Asynchronous : boolean; -- end record; Set_Chars (Defining_Id, New_Name); Record_Ty := Make_Full_Type_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Old_Name), Type_Definition => Make_Record_Definition (Loc, Component_List => Make_Component_List (Loc, Component_Items => New_List ( Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Ast_Receiver), Subtype_Indication => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Rpc_Receiver))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Pointer), Subtype_Indication => Make_Identifier (Loc, New_Name)), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Pid), Subtype_Indication => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Partition_ID))), Make_Component_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Asynchronous), Subtype_Indication => Make_Identifier (Loc, Chars (Standard_Boolean))))))); Insert_After (N, Record_Ty); -- Now add declaration of the subprogram that would handle dereference. -- The signature has an extra parameter to pass in the fat pointer. -- For example, -- procedure oldnameD (pointer : oldname; arg : arg_type); -- would be the new added declaration in our example. -- Such declaration is one per remote access to subprogram type. NN := Copy_Separate_Tree (N); N1 := Copy_Separate_Tree (N); PL := Parameter_Specifications (Type_Definition (NN)); Ori_Arg_List := Parameter_Specifications (Type_Definition (N1)); Arg_List := PL; PS := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Pointer), Parameter_Type => Make_Identifier (Loc, Old_Name)); Prepend (PS, PL); if Nkind (Type_Definition (N)) = N_Access_Function_Definition then SM := Copy_Separate_Tree (Subtype_Mark (Type_Definition (N))); SD := Make_Subprogram_Declaration (Loc, Make_Function_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Sub_Name), Parameter_Specifications => PL, Subtype_Mark => SM)); elsif Nkind (Type_Definition (N)) = N_Access_Procedure_Definition then SD := Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Sub_Name), Parameter_Specifications => PL)); end if; Insert_After (Record_Ty, SD); -- Now add declaration of the subprogram that would handle receiving -- for remote call. The declaration is: -- procedure remote_access_to_subprogram_typeR -- (params : access system.rpc.params_stream_type; -- result : access system.rpc.params_stream_type); -- This receiver is one per remote access to subprogram type type -- params : access system.rpc.params_stream_type; PL := New_List; PS := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Params), Parameter_Type => Make_Access_Definition (Loc, Subtype_Mark => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Params_Stream_Type)))); Append (PS, PL); -- result : access system.rpc.params_stream_type PS := Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Result), Parameter_Type => Make_Access_Definition (Loc, Subtype_Mark => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Params_Stream_Type)))); Append (PS, PL); AST_RVR := Make_Subprogram_Declaration (Loc, Specification => Make_Procedure_Specification (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, New_External_Name (Old_Name, 'R', 0, ' ')), Parameter_Specifications => PL)); Insert_After (SD, AST_RVR); -- Return if the RCI or Remote Types unit specification is not -- currently compiled with its body but is rather compiled with -- other withing unit. Nd := Parent (N); if Nkind (Nd) /= N_Package_Specification then return; end if; Name1 := Chars (Defining_Unit_Name (Nd)); Nd := Unit (Cunit (Main_Unit)); if Nkind (Nd) /= N_Package_Body then return; end if; Name2 := Chars (Defining_Unit_Name (Nd)); if Name1 /= Name2 then return; end if; -- Now add the subprogram body that handles the dereference of values -- of such remote access to subprogram type to the RCI, Remote Types -- package body. -- Differentiate function body and procedure body. DL := Declarations (Nd); Nd := Copy_Separate_Tree (SD); SP := Specification (Nd); SL := New_List; DL2 := New_List; Name3 := New_External_Name ('R', 0); Name4 := New_External_Name ('S', 1); Name5 := New_External_Name ('S', 2); Name6 := New_External_Name ('E', 3); if Nkind (Type_Definition (N)) = N_Access_Function_Definition then SM := Copy_Separate_Tree (Subtype_Mark (Type_Definition (N))); -- R0 : return_type; Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name3), Object_definition => SM); Append (Nd, DL2); Nd := Make_Return_Statement (Loc, Expression => Make_Identifier (Loc, Name3)); Append (Nd, SL); end if; -- S1 : system.rpc.params_stream_type (0); Append (Make_Integer_Literal (Loc, Uint_0), L1); Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name4), Object_definition => Make_Subtype_Indication (Loc, Subtype_Mark => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Params_Stream_Type)), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => L1))); Set_Aliased_Present (Nd, True); Append (Nd, DL2); -- S2 : system.rpc.params_stream_type (0); L1 := New_List; Append (Make_Integer_Literal (Loc, Uint_0), L1); Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name5), Object_definition => Make_Subtype_Indication (Loc, Subtype_Mark => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Params_Stream_Type)), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => L1))); Set_Aliased_Present (Nd, True); Append (Nd, DL2); -- E3 : ada.exceptions.exception_occurrence; Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name6), Object_definition => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Name_Exception_Occurrence))); Append (Nd, DL2); -- system.rpc.rpc_receiver'write (s1'access, pointer.ast_receiver); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name4), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Pointer), Selector_Name => Make_Identifier (Loc, Name_Ast_Receiver)); Append (Nd, L1); Nd1 := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Rpc_Receiver)), Attribute_Name => Name_Write, Expressions => L1)); Prepend (Nd1, SL); -- newname'write (s1'access, pointer.pointer); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name4), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Pointer), Selector_Name => Make_Identifier (Loc, Name_Pointer)); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, New_Name), Attribute_Name => Name_Write, Expressions => L1)); Insert_After (Nd1, Nd); Nd1 := Nd; -- Now, for each parameter in the original remote subprogram parameter -- list do a write to the parameter stream. Param := First (Ori_Arg_List); while Present (Param) loop Param_Type := Copy_Separate_Tree (Parameter_Type (Param)); Arg := Copy_Separate_Tree (Defining_Identifier (Param)); -- param_type'write (s1'access, arg); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name4), Attribute_Name => Name_Access); Append (Nd, L1); Append (Arg, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Param_Type, Attribute_Name => Name_Write, Expressions => L1)); Insert_After (Nd1, Nd); Nd1 := Nd; Param := Next (Param); end loop; -- Depending on whether the fat pointer component asynchronous -- is True or False, we do a -- system.rpc.do_apc or system.rpc.do_rpc -- -- if pointer.asynchronous then -- system.rpc.do_apc (pointer.pid, s1'access); -- return; -- else -- system.rpc.do_rpc (pointer.pid, s1'access, s2'access); -- end if; -- system.rpc.do_apc (pointer.pid, s1'access); L1 := New_List; Nd := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Pointer), Selector_Name => Make_Identifier (Loc, Name_Pid)); Append (Nd, L1); Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name4), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Do_Apc)), Parameter_Associations => L1); Append (Nd, Then_Stmts); -- return; Nd := Make_Return_Statement (Loc); Append (Nd, Then_Stmts); -- system.rpc.do_rpc (pointer.pid, s1'access, s2'access); L1 := New_List; Nd := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Pointer), Selector_Name => Make_Identifier (Loc, Name_Pid)); Append (Nd, L1); Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name4), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name5), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_System), Selector_Name => Make_Identifier (Loc, Name_Rpc)), Selector_Name => Make_Identifier (Loc, Name_Do_Rpc)), Parameter_Associations => L1); Append (Nd, Else_Stmts); -- If ... then .. else .. Nd := Make_If_Statement (Loc, Condition => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Pointer), Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), Then_Statements => Then_Stmts, Else_Statements => Else_Stmts); Insert_After (Nd1, Nd); Nd1 := Nd; -- Now, for each out parameter in the original remote subprogram -- parameter list do a read from the result stream to arg. Param := First (Ori_Arg_List); while Present (Param) loop if Out_Present (Param) then Param_Type := Copy_Separate_Tree (Parameter_Type (Param)); Arg := Copy_Separate_Tree (Defining_Identifier (Param)); -- param_type'read (s2'access, arg); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name5), Attribute_Name => Name_Access); Append (Nd, L1); Append (Arg, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Param_Type, Attribute_Name => Name_Read, Expressions => L1)); Insert_After (Nd1, Nd); Nd1 := Nd; end if; Param := Next (Param); end loop; -- Now, in case of function, for the return type in original remote -- subprogram specification do a read from the result stream to arg. if Nkind (Type_Definition (N)) = N_Access_Function_Definition then SM := Copy_Separate_Tree (Subtype_Mark (Type_Definition (N))); -- return_type'read (s2'access, r0); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name5), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Identifier (Loc, Name3); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => SM, Attribute_Name => Name_Read, Expressions => L1)); Insert_After (Nd1, Nd); Nd1 := Nd; end if; -- ada.exceptions.exception_occurrence'read (s2'access, e3); L1 := New_List; Nd := Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, Name5), Attribute_Name => Name_Access); Append (Nd, L1); Nd := Make_Identifier (Loc, Name6); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Name_Exception_Occurrence)), Attribute_Name => Name_Read, Expressions => L1)); Insert_After (Nd1, Nd); Nd1 := Nd; -- if ada.exceptions.exception_identity (e3) /= -- ada.exceptions.null_id -- then -- ada.exceptions.reraise_occurrence (e3); -- end if; -- ada.exceptions.reraise_occurrence (e3); L1 := New_List; Nd := Make_Identifier (Loc, Name6); Append (Nd, L1); Reraise_Nm := Get_Name_Id ("reraise_occurrence"); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Reraise_Nm)), Parameter_Associations => L1); Then_Stmts := New_List; Append (Nd, Then_Stmts); -- Condition left operand -- ada.exceptions.exception_identity (e3) L1 := New_List; Nd := Make_Identifier (Loc, Name6); Append (Nd, L1); Left_Opnd := Make_Indexed_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Name_Exception_Identity)), Expressions => L1); -- Condition right operand -- ada.exceptions.null_id Right_Opnd := Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Name_Null_Id)); Nd := Make_If_Statement (Loc, Condition => Make_Op_Ne (Loc, Left_Opnd => Left_Opnd, Right_Opnd => Right_Opnd), Then_Statements => Then_Stmts); Insert_After (Nd1, Nd); Nd1 := Nd; Nd := Make_Subprogram_Body (Loc, Specification => SP, Declarations => DL2, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => SL)); Prepend (Nd, DL); -- Now add body of the subprogram that would handle receiving -- for remote call: -- procedure remote_access_to_subprogram_typeR -- (params : access system.rpc.params_stream_type; -- result : access system.rpc.params_stream_type) is ... Nd := Copy_Separate_Tree (AST_RVR); SP := Specification (Nd); SL := New_List; DL2 := New_List; Name7 := New_External_Name ('P', 1); Name8 := New_External_Name ('E', 2); -- Some local declarations. -- P1 : newname; Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name7), Object_definition => Make_Identifier (Loc, New_Name)); Append (Nd, DL2); -- In case this remote subprogram is a function, declare a local -- variable to contain the return value. if Nkind (Type_Definition (N)) = N_Access_Function_Definition then SM := Copy_Separate_Tree (Subtype_Mark (Type_Definition (N))); -- R0 : return_type; Nd := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name3), Object_definition => SM); Append (Nd, DL2); end if; -- Now, for each parameter in the original remote subprogram parameter -- list declare a variable (with name param_nameN) for it. Param := First (Ori_Arg_List); while Present (Param) loop Arg := Defining_Identifier (Param); Set_Chars (Arg, New_External_Name (Chars (Arg), 'N', 0, ' ')); Param_Type := Copy_Separate_Tree (Parameter_Type (Param)); Arg := Copy_Separate_Tree (Defining_Identifier (Param)); -- param_nameN : param_type; Nd := Make_Object_Declaration (Loc, Defining_Identifier => Arg, Object_definition => Param_Type); Append (Nd, DL2); Param := Next (Param); end loop; -- Read from stream the pointer to remote subprogram. -- newname'read (params, p1); L1 := New_List; Nd := Make_Identifier (Loc, Name_Params); Append (Nd, L1); Nd := Make_Identifier (Loc, Name7); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Make_Identifier (Loc, New_Name), Attribute_Name => Name_Read, Expressions => L1)); Append (Nd, SL); -- Now initialize these (corresponding argument) variables with their -- values from (reading) stream. Param := First (Ori_Arg_List); while Present (Param) loop Param_Type := Copy_Separate_Tree (Parameter_Type (Param)); Arg := Make_Identifier (Loc, Chars (Defining_Identifier (Param))); -- param_type'read (params, arg); L1 := New_List; Nd := Make_Identifier (Loc, Name_Params); Append (Nd, L1); Append (Arg, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Param_Type, Attribute_Name => Name_Read, Expressions => L1)); Append (Nd, SL); Param := Next (Param); end loop; -- Now, make a call to the (remote) subprrogram with arguments read -- from stream. -- In case the original remote subprogram is a function then store -- returned value into variable R0. -- p1 (arg1, arg2 , ... ); -- or -- R0 := p1 (arg1, arg2 , ... ); -- Collecting the arguments L1 := New_List; Param := First (Ori_Arg_List); while Present (Param) loop Arg := Make_Identifier (Loc, Chars (Defining_Identifier (Param))); Append (Arg, L1); Param := Next (Param); end loop; if Nkind (Type_Definition (N)) = N_Access_Function_Definition then -- R0 := p1 (arg1, arg2 , ... ); Nd := Make_Assignment_Statement (Loc, Name => Make_Identifier (Loc, Name3), Expression => Make_Indexed_Component (Loc, Prefix => Make_Identifier (Loc, Name7), Expressions => L1)); Append (Nd, SL); else -- p1 (arg1, arg2 , ... ); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Identifier (Loc, Name7), Parameter_Associations => L1); Append (Nd, SL); end if; -- Now, for each out parameter in the original remote subprogram -- parameter list do a write to the result stream from arg. Param := First (Ori_Arg_List); while Present (Param) loop if Out_Present (Param) then Param_Type := Copy_Separate_Tree (Parameter_Type (Param)); Arg := Copy_Separate_Tree (Defining_Identifier (Param)); -- param_type'write (result, arg); L1 := New_List; Nd := Make_Identifier (Loc, Name_Result); Append (Nd, L1); Append (Arg, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Param_Type, Attribute_Name => Name_Write, Expressions => L1)); Append (Nd, SL); end if; Param := Next (Param); end loop; -- Now, in case of function, for the return type in original remote -- subprogram specification do a read from the result stream to arg. if Nkind (Type_Definition (N)) = N_Access_Function_Definition then SM := Copy_Separate_Tree (Subtype_Mark (Type_Definition (N))); -- return_type'write (result, r0); L1 := New_List; Nd := Make_Identifier (Loc, Name_Result); Append (Nd, L1); Nd := Make_Identifier (Loc, Name3); Append (Nd, L1); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => SM, Attribute_Name => Name_Write, Expressions => L1)); Append (Nd, SL); end if; -- Now construct the exception handler -- exception -- when E2 : others => -- ada.exceptions.exception_occurrence'write (result,E2); L1 := New_List; Nd := Make_Others_Choice (Loc); Append (Nd, L1); -- ada.exceptions.exception_occurrence'write (result, e2); L3 := New_List; L2 := New_List; Nd := Make_Identifier (Loc, Name_Result); Append (Nd, L2); Nd := Make_Identifier (Loc, Name8); Append (Nd, L2); Nd := Make_Procedure_Call_Statement (Loc, Name => Make_Attribute_Reference (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Name_Ada), Selector_Name => Make_Identifier (Loc, Name_Exceptions)), Selector_Name => Make_Identifier (Loc, Name_Exception_Occurrence)), Attribute_Name => Name_Write, Expressions => L2)); Append (Nd, L3); Nd := Make_Exception_Handler (Loc, Choice_Parameter => Make_Defining_Identifier (Loc, Name8), Exception_Choices => L1, Statements => L3); L2 := New_List; Append (Nd, L2); -- Now create the receiver subprogram body -- Append to package declarations Nd := Make_Subprogram_Body (Loc, Specification => SP, Declarations => DL2, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => SL, Exception_Handlers => L2)); Prepend (Nd, DL); end Process_Remote_AST_Declaration; ------------------------------------------- -- Process_Remote_Access_Subprogram_Type -- ------------------------------------------- procedure Process_Remote_Access_Subprogram_Type (N : Node_Id) is Id : constant Entity_Id := Defining_Unit_Simple_Name (N); Vi : constant List_Id := Visible_Declarations (N); Pr : constant List_Id := Private_Declarations (N); Dn : Node_Id; Fl : List_Id := New_List; Pl : List_Id := New_List; Tl : List_Id := New_List; Sp : Node_Id; Ft : Node_Id; Pt : Node_Id; Df : Node_Id; procedure Build_Lists (L : List_Id); -- Given input list L, seperate declarations into three lists, one -- access type list, one function specification list and one -- procedure specification list procedure Build_Lists (L : List_Id) is Decl : Node_Id := First (L); begin while Present (Decl) loop if Nkind (Decl) = N_Subprogram_Declaration then Sp := Specification (Decl); if Nkind (Sp) = N_Procedure_Specification then Append (Sp, Pl); elsif Nkind (Sp) = N_Function_Specification then Append (Sp, Fl); end if; elsif Nkind (Decl) = N_Full_Type_Declaration then Df := Type_Definition (Decl); if Present (Df) then if Nkind (Df) = N_Access_Procedure_Definition or else Nkind (Df) = N_Access_Function_Definition then Append (Df, Tl); end if; end if; end if; Decl := Next (Decl); end loop; end Build_Lists; -- Start processing of Process_Remote_Access_Subprogram_Type begin if Present (Vi) then Build_Lists (Vi); end if; if Present (Pr) then Build_Lists (Pr); end if; -- Return if no remote access to subprogram type declaration if not Present (Tl) then return; end if; return; end Process_Remote_Access_Subprogram_Type; ------------------------------ -- Remote_AST_E_Dereference -- ------------------------------ function Remote_AST_E_Dereference (P : Node_Id; UAN : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); SCP : constant Entity_Id := Scope (ET); Loc : constant Source_Ptr := Sloc (P); FAT : Node_Id; Nd1 : Node_Id; Sub_Name : Name_Id; begin -- Rewrite the prefix node only if it is of an internal remote record -- (fat pointer) type whose first component is "Ast_Receiver". if Ekind (ET) /= E_Record_Type or else Comes_From_Source (ET) or else (not Is_Remote_Call_Interface (ET) and then not Is_Remote_Types (ET)) or else Chars (First_Entity (ET)) /= Name_Ast_Receiver then return False; end if; -- At this point, the original source program was: -- Name_of_Remote_Access_To_Subprogram_Type.all (arg1, arg2) -- This has been transformed by Process_Remote_AST_Declaration to -- Name_of_Remote_Fat_Pointer_Type.all (arg1, arg2)" -- since the fat pointer type has been substituted for the type -- name of the remove access to subprogram type. We now carry -- out a further transformation to get: -- Remote_Fat_Pointer_Type_NameD -- (Name_of_Remote_Fat_Pointer_Type, arg1, arg2)" -- which is a call to the subprogram that handles the dereference for -- this paticular fat pointer type. Notice the fat pointer value is -- passed in as an argumant. The result of this call will be a remote -- call to the remote subprogram. -- Copy the original unanalyzed prefix, prepend it to argument list -- of parent of parent of prefix, which is an N_Indexed_Component node. FAT := Copy_Separate_Tree (Prefix (UAN)); Prepend (FAT, Expressions (Parent (Parent (P)))); -- Change prefix name from XXX.Name to YYY.Fat_Pointer_TypeD and Sub_Name := New_External_Name (Chars (ET), 'D', 0, ' '); Nd1 := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Chars (SCP)), Selector_Name => Make_Identifier (Loc, Sub_Name)); -- Analyze the rewritten prefix before return and then set the -- prefix of N_Indexed_Component to be name of the subprogram -- that handles dereference. Analyze (Nd1); Rewrite_Substitute_Tree (Parent (P), Nd1); return True; end Remote_AST_E_Dereference; ------------------------------ -- Remote_AST_I_Dereference -- ------------------------------ function Remote_AST_I_Dereference (P : Node_Id; UAN : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); SCP : constant Entity_Id := Scope (ET); Loc : constant Source_Ptr := Sloc (P); FAT : Node_Id; Nd1 : Node_Id; Sub_Name : Name_Id; begin -- Rewrite the indexed component node only if prefix of original node -- is of an internal remote record (fat pointer) type whose first -- component is "Ast_Receiver". if Ekind (ET) /= E_Record_Type or else Comes_From_Source (ET) or else (not Is_Remote_Call_Interface (ET) and then not Is_Remote_Types (ET)) or else Chars (First_Entity (ET)) /= Name_Ast_Receiver then return False; end if; -- At this point, the original source program was: -- Name_of_Remote_Access_To_Subprogram_Type (arg1, arg2) -- This has been transformed by Process_Remote_AST_Declaration to -- Name_of_Remote_Fat_Pointer_Type (arg1, arg2)" -- since the fat pointer type has been substituted for the type -- name of the remove access to subprogram type. We now carry -- out a further transformation to get: -- Remote_Fat_Pointer_Type_NameD -- (Name_of_Remote_Fat_Pointer_Type, arg1, arg2)" -- which is a call to the subprogram that handles the dereference for -- this paticular fat pointer type. Notice the fat pointer value is -- passed in as an argumant. The result of this call will be a remote -- call to the remote subprogram. -- Copy the original unanalyzed prefix, prepend it to argument list FAT := Copy_Separate_Tree (Prefix (UAN)); Prepend (FAT, Expressions (UAN)); -- Change prefix name from XXX.Name to YYY.Fat_Pointer_TypeD Sub_Name := New_External_Name (Chars (ET), 'D', 0, ' '); Nd1 := Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Chars (SCP)), Selector_Name => Make_Identifier (Loc, Sub_Name)); Set_Prefix (UAN, Nd1); Analyze (UAN); Rewrite_Substitute_Tree (Parent (P), UAN); return True; end Remote_AST_I_Dereference; ----------------------------------------------- -- Set_Categorization_From_Following_Pragmas -- ----------------------------------------------- procedure Set_Categorization_From_Following_Pragmas (N : Node_Id) is P : constant Node_Id := Parent (N); begin -- Deal with categorization pragmas in Following_Pragmas -- of Compilation_Unit. The purpose is to set flags. -- This code seems misplaced, it has nothing to do with distribution -- really, following pragmas must be handled more generally ??? if Nkind (P) /= N_Compilation_Unit then return; end if; if Present (Following_Pragmas (P)) then declare Pragma_Node : Node_Id := First (Following_Pragmas (P)); begin while Present (Pragma_Node) loop case Get_Pragma_Id (Chars (Pragma_Node)) is when Pragma_All_Calls_Remote => Analyze (Pragma_Node); when Pragma_Preelaborate => Analyze (Pragma_Node); when Pragma_Pure => Analyze (Pragma_Node); when Pragma_Remote_Call_Interface => Analyze (Pragma_Node); when Pragma_Remote_Types => Analyze (Pragma_Node); when Pragma_Shared_Passive => Analyze (Pragma_Node); when others => null; end case; Pragma_Node := Next (Pragma_Node); end loop; end; end if; end Set_Categorization_From_Following_Pragmas; --------------------------------- -- Should_Declare_Partition_ID -- --------------------------------- function Should_Declare_Partition_ID (L : List_Id) return Boolean is Nd : Node_Id := First (L); Ch : Name_Id; Na : Node_Id := Defining_Unit_Name (Parent (L)); begin while Present (Nd) loop if Nkind (Nd) = N_Pragma then Ch := Chars (Nd); if Ch = Name_Preelaborate or else Ch = Name_Remote_Call_Interface or else Ch = Name_Shared_Passive or else Ch = Name_Remote_Types then return True; elsif Ch = Name_Pure then return False; end if; end if; Nd := Next (Nd); end loop; -- This is a non-categorizaed library unit if Nkind (Na) = N_Defining_Program_Unit_Name and then Nkind (Name (Na)) = N_Identifier and then Chars (Name (Na)) = Name_System and then Nkind (Defining_Identifier (Na)) = N_Defining_Identifier and then Chars (Defining_Identifier (Na)) = Name_Rpc then return True; end if; return False; end Should_Declare_Partition_ID; ------------------------------ -- Static_Discriminant_Expr -- ------------------------------ function Static_Discriminant_Expr (L : List_Id) return Boolean is Discriminant_Spec : Node_Id; begin Discriminant_Spec := First (L); while Present (Discriminant_Spec) loop if Present (Expression (Discriminant_Spec)) and then not Is_Static_Expression (Expression (Discriminant_Spec)) then return False; end if; Discriminant_Spec := Next (Discriminant_Spec); end loop; return True; end Static_Discriminant_Expr; -------------------------------------- -- Validate_Access_Type_Declaration -- -------------------------------------- procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is Def : constant Node_Id := Type_Definition (N); begin case Nkind (Def) is when N_Access_To_Subprogram_Definition => -- A pure library_item must not contain the declaration of a -- named access type, except within a subprogram, generic -- subprogram, task unit, or protected unit (RM 10.2.1(16)). if Comes_From_Source (T) and then Inside_Pure_Unit and then not Inside_Subprogram_Task_Protected_Unit then Error_Msg_N ("named access type not allowed in pure unit", T); end if; -- Set Is_Remote_Call_Interface flag on entity to allow easy -- checks later on for required validations of RCI units. This -- is only done for entities that are in the original source. if Comes_From_Source (T) and then Inside_Remote_Call_Interface_Unit then Set_Is_Remote_Call_Interface (T); end if; -- Set Is_Remote_Types flag on entity to allow easy -- checks later on for required validations of such units. This -- is only done for entities that are in the original source. if Comes_From_Source (T) and then Inside_Remote_Types_Unit then Set_Is_Remote_Types (T); end if; when N_Access_To_Object_Definition => if Comes_From_Source (T) and then Inside_Pure_Unit and then not Inside_Subprogram_Task_Protected_Unit then Error_Msg_N ("named access type not allowed in pure unit", T); end if; -- Check for RCI unit type declaration. It should not contain -- the declaration of an access-to-object type unless it is a -- general access type that designates a class-wide limited -- private type. There are also constraints about the primitive -- subprograms of the class-wide type. Validate_RCI_Access_Object_Type_Declaration (T); -- Check for shared passive unit type declaration. It should -- not contain the declaration of access to class wide type, -- access to task type and access to protected type with entry. Validate_SP_Access_Object_Type_Decl (T); -- Set Is_Remote_Types flag on entity to allow easy -- checks later on for required validations of such units. This -- is only done for entities that are in the original source. if Comes_From_Source (T) and then Inside_Remote_Types_Unit then Set_Is_Remote_Types (T); end if; when others => null; end case; end Validate_Access_Type_Declaration; ---------------------------------------- -- Validate_Categorization_Dependency -- ---------------------------------------- procedure Validate_Categorization_Dependency (N : Node_Id; E : Entity_Id) is K : constant Node_Kind := Nkind (N); P : constant Node_Id := Parent (N); begin -- Validate library unit only if Nkind (P) /= N_Compilation_Unit then return; end if; -- Body of RCI unit does not need validation. if Is_Remote_Call_Interface (E) and then (Nkind (N) = N_Package_Body or else Nkind (N) = N_Subprogram_Body) then return; end if; -- Process with clauses declare Item : Node_Id; Entity_Of_Withed : Entity_Id; begin Item := First (Context_Items (P)); while Present (Item) loop if Nkind (Item) = N_With_Clause and then not Implicit_With (Item) then Entity_Of_Withed := Entity (Name (Item)); Check_Categorization_Dependencies (E, Entity_Of_Withed, Item); end if; Item := Next (Item); end loop; end; -- Child depends on parent therefore parent should also -- be categorized and satify the dependecy hierarchy. -- Check if N is a child spec. if (K in N_Generic_Declaration or else K in N_Generic_Instantiation or else K in N_Generic_Renaming_Declaration or else K = N_Package_Declaration or else K = N_Package_Renaming_Declaration or else K = N_Subprogram_Declaration or else K = N_Subprogram_Renaming_Declaration) and then Present (Parent_Spec (N)) then declare Parent_Lib_U : constant Node_Id := Parent_Spec (N); Parent_Kind : constant Node_Kind := Nkind (Unit (Parent_Lib_U)); Parent_Entity : Entity_Id; begin if Parent_Kind = N_Package_Instantiation or else Parent_Kind = N_Procedure_Instantiation or else Parent_Kind = N_Function_Instantiation or else Parent_Kind = N_Package_Renaming_Declaration or else Parent_Kind in N_Generic_Renaming_Declaration then Parent_Entity := Defining_Unit_Simple_Name (Unit (Parent_Lib_U)); else Parent_Entity := Defining_Unit_Simple_Name (Specification (Unit (Parent_Lib_U))); end if; Check_Categorization_Dependencies (E, Parent_Entity, N); -- Verify that public child of an RCI library unit -- must also be an RCI library unit (RM E.2.3(15)). if Is_Remote_Call_Interface (Parent_Entity) and then not Private_Present (P) and then not Is_Remote_Call_Interface (E) then Error_Msg_N ("public child of rci unit must also be rci unit", N); return; end if; end; end if; end Validate_Categorization_Dependency; ------------------------------ -- Validate_Non_Static_Call -- ------------------------------ procedure Validate_Non_Static_Call (N : Node_Id) is begin if not Inside_Subprogram_Unit and then Inside_Preelaborated_Unit and then Comes_From_Source (Entity (Name (N))) then -- Check for the case where run time source for tasking -- is making the call. Validation is skipped in this case if Nkind (Parent (N)) = N_Object_Declaration and then not Comes_From_Source (Defining_Identifier (Parent (N))) then return; -- Check for the case where initialization function for -- tagged type is called. Validation is skipped in this case elsif Nkind (Parent (N)) = N_Range and then not Comes_From_Source (Etype (Parent (N))) then return; -- Check for the case where initialization function for -- tagged type is called. Validation is skipped in this case elsif Present (Parameter_Associations (N)) and then not Comes_From_Source (Entity (First (Parameter_Associations (N)))) then return; -- Check for subprogram calls in freeze list elsif Present (Parent (N)) and then Nkind (Parent (N)) = N_Freeze_Entity then return; end if; Error_Msg_N ("non-static call not allowed in preelaborated unit", N); end if; end Validate_Non_Static_Call; -------------------------------------- -- Validate_Null_Statement_Sequence -- -------------------------------------- procedure Validate_Null_Statement_Sequence (N : Node_Id) is Item : Node_Id; begin if Inside_Preelaborated_Unit then Item := First (Statements (Handled_Statement_Sequence (N))); while Present (Item) loop if Nkind (Item) /= N_Label and then Nkind (Item) /= N_Null_Statement then Error_Msg_N ("statements not allowed in preelaborated unit", Item); exit; end if; Item := Next (Item); end loop; end if; end Validate_Null_Statement_Sequence; --------------------------------- -- Validate_Object_Declaration -- --------------------------------- procedure Validate_Object_Declaration (N : Node_Id; Id : Entity_Id; E : Node_Id; Odf : Node_Id; T : Entity_Id) is begin -- Verify that any access to subprogram object does not have in its -- subprogram profile access type parameters or limited parameters -- without Read and Write attributes (E.2.3(13)). Validate_RCI_Subprogram_Declaration (N); -- Check that if we are in preelaborated elaboration code, then we -- do not have an instance of a default initialized private, task or -- protected object declaration which would violate (RM 10.2.1(9)). -- Note that constants are never default initialized (and the test -- below also filters out deferred constants). A variable is default -- initialized if it does *not* have an initialization expression. -- Filter out cases that are not declaration of a variable from source. if Nkind (N) /= N_Object_Declaration or else Constant_Present (N) or else not Comes_From_Source (Id) then return; end if; if Inside_Preelaborated_Unit and then not Inside_Subprogram_Unit then if No (E) then declare Ent : Entity_Id; begin -- Object decl. that is of record type and has no default expr. -- should check if there is any non-static default expression -- in component decl. of the record type decl. if Is_Record_Type (T) then if Nkind (Parent (T)) = N_Full_Type_Declaration then Check_Non_Static_Default_Expr (Component_Items (Component_List (Type_Definition (Parent (T))))); elsif Nkind (Odf) = N_Subtype_Indication then Check_Non_Static_Default_Expr (Component_Items (Component_List (Type_Definition (Parent (Entity ( Subtype_Mark (Odf))))))); end if; end if; -- Similarly, array whose component type is record of component -- declarations with default expression that is non-static -- is a violation. if Is_Array_Type (T) then if Nkind (Parent (T)) = N_Full_Type_Declaration then declare Comp_Type : Entity_Id := Component_Type (T); begin while Is_Array_Type (Comp_Type) loop Comp_Type := Component_Type (Comp_Type); end loop; if Is_Record_Type (Comp_Type) then if Nkind (Parent (Comp_Type)) = N_Full_Type_Declaration then Check_Non_Static_Default_Expr (Component_Items (Component_List (Type_Definition (Parent (Comp_Type))))); end if; end if; end; end if; end if; if Is_Private_Type (Id) or else (Is_Access_Type (T) and then Depends_On_Private (Directly_Designated_Type (T))) or else Depends_On_Private (T) then Error_Msg_N ("private object not allowed in preelaborated unit", N); return; -- Access to Task or Protected type elsif Nkind (Odf) = N_Identifier and then Present (Etype (Odf)) and then Is_Access_Type (Etype (Odf)) then Ent := Directly_Designated_Type (Etype (Odf)); elsif Nkind (Odf) = N_Identifier then Ent := Entity (Odf); elsif Nkind (Odf) = N_Subtype_Indication then Ent := Etype (Subtype_Mark (Odf)); elsif Nkind (Odf) = N_Constrained_Array_Definition then Ent := Etype (Subtype_Indication (Odf)); else return; end if; if Is_Task_Type (Ent) or else (Is_Protected_Type (Ent) and then Has_Entries (Ent)) then Error_Msg_N ("concurrent object not allowed in preelaborated unit", N); return; end if; end; end if; -- Evaluation of discriminant default expr. is done when obj. -- is created. And it has to be static expr. if Is_Record_Type (Etype (Id)) then declare ET : constant Entity_Id := Etype (Id); EE : constant Entity_Id := Etype (Etype (Id)); PEE : Node_Id; begin if Has_Discriminants (ET) and then Present (EE) then PEE := Parent (EE); if Nkind (PEE) = N_Full_Type_Declaration and then not Static_Discriminant_Expr (Discriminant_Specifications (PEE)) then Error_Msg_N ("non-static discriminant in preelaborated unit", PEE); end if; end if; end; end if; -- Similarly, array whose component type is record of component -- declarations with discriminant expression that is non-static -- is a violation. if Is_Array_Type (T) then if Nkind (Parent (T)) = N_Full_Type_Declaration then declare Comp_Type : Entity_Id := Component_Type (T); begin while Is_Array_Type (Comp_Type) loop Comp_Type := Component_Type (Comp_Type); end loop; if Is_Record_Type (Comp_Type) and then Has_Discriminants (Comp_Type) and then Nkind (Parent (Comp_Type)) = N_Full_Type_Declaration and then not Static_Discriminant_Expr (Discriminant_Specifications (Parent (Comp_Type))) then Error_Msg_N ("non-static discriminant in preelaborated unit", Comp_Type); end if; end; end if; end if; end if; -- A pure library_item must not contain the declaration of any -- variable except within a subprogram, generic subprogram, task -- unit or protected unit (RM 10.2.1(16)). if Inside_Pure_Unit and then not Inside_Subprogram_Task_Protected_Unit then Error_Msg_N ("declaration of variable not allowed in pure unit", N); -- The visible part of an RCI library unit must not contain the -- declaration of a variable (RM E.1.3(9)) elsif Inside_Remote_Call_Interface_Unit then Error_Msg_N ("declaration of variable not allowed in rci unit", N); -- The visible part of a Shared Passive library unit must not contain -- the declaration of a variable (RM E.2.2(7)) elsif Inside_Remote_Types_Unit then Error_Msg_N ("variable declaration not allowed in remote types unit", N); end if; end Validate_Object_Declaration; ------------------------------------------------- -- Validate_RCI_Access_Object_Type_Declaration -- ------------------------------------------------- procedure Validate_RCI_Access_Object_Type_Declaration (T : Entity_Id) is Direct_Designated_Type : Entity_Id; Designated_Type : Entity_Id; Primitive_Subprograms : Elist_Id; Type_Decl : Node_Id; Subprogram : Elmt_Id; Subprogram_Node : Node_Id; Profile : List_Id; Param_Spec : Node_Id; Param_Type : Entity_Id; Limited_Type : Entity_Id; Limited_Type_Decl : Node_Id; Item : Node_Id; Nm : Name_Id; Read_Spec : Node_Id; Read_Type : Entity_Id; Write_Spec : Node_Id; Write_Type : Entity_Id; Found_Read : Boolean := False; Found_Write : Boolean := False; begin -- We are called from Analyze_Type_Declaration, and the Nkind -- of the given node is N_Access_To_Object_Definition. if not Comes_From_Source (T) or else not Inside_Remote_Call_Interface_Unit then return; end if; -- Check RCI unit type declaration. It should not contain the -- declaration of an access-to-object type unless it is a -- general access type that designates a class-wide limited -- private type. There are also constraints about the primitive -- subprograms of the class-wide type (RM E.2.3(14)). if Ekind (T) /= E_General_Access_Type then Error_Msg_N ("must be general access-to-class-wide limited type in rci unit", T); return; end if; Direct_Designated_Type := Directly_Designated_Type (T); if Ekind (Direct_Designated_Type) /= E_Class_Wide_Type then Error_Msg_N ("must be general access-to-class-wide limited type in rci unit", T); return; end if; Designated_Type := Etype (Direct_Designated_Type); Type_Decl := Parent (Designated_Type); if Nkind (Type_Decl) /= N_Private_Type_Declaration or else not Limited_Present (Type_Decl) or else Primitive_Operations (Designated_Type) = No_Elist then Error_Msg_N ("in rci must be limited private designated type with operation", T); return; end if; Primitive_Subprograms := Primitive_Operations (Designated_Type); Subprogram := First_Elmt (Primitive_Subprograms); while Subprogram /= No_Elmt loop Subprogram_Node := Node (Subprogram); if not Comes_From_Source (Subprogram_Node) then goto Next_Subprogram; end if; Profile := Parameter_Specifications (Parent (Subprogram_Node)); -- Profile must exist, otherwise not primitive operation Param_Spec := First (Profile); while Present (Param_Spec) loop -- Now find out if this parameter is a controlling parameter Param_Type := Parameter_Type (Param_Spec); if Nkind (Param_Type) = N_Identifier and then Etype (Param_Type) = Designated_Type then -- It is indeed a controlling parameter, and since it's not -- an access parameter, this is a violation. Error_Msg_N ("not access control parameter in rci unit", Param_Spec); elsif Nkind (Param_Type) = N_Access_Definition and then Subtype_Mark (Param_Type) = Designated_Type then -- It is indeed controlling parameter but since it's an -- access parameter, this is not a violation. null; elsif Is_Limited_Type (Etype (Defining_Identifier (Param_Spec))) then -- Not a controlling parameter, so type must have Read -- and Write attributes. if Nkind (Param_Type) = N_Identifier and then Nkind (Parent (Etype (Param_Type))) = N_Private_Type_Declaration then Param_Type := Etype (Param_Type); Limited_Type_Decl := Parent (Param_Type); -- Now looking for Read and Write through rest of decl list Item := Next (Limited_Type_Decl); while Present (Item) loop if Nkind (Item) = N_Subprogram_Declaration and then Present (Parameter_Specifications (Specification (Item))) then Nm := Chars (Defining_Unit_Name (Specification (Item))); -- If name match read or write then iterate through -- its list of parameter specifications, looking for -- a match in the target limited type. if Nm = Name_Read then Read_Spec := First (Parameter_Specifications (Specification (Item))); while Present (Read_Spec) loop Read_Type := Etype (Defining_Identifier (Read_Spec)); if Read_Type = Param_Type then Found_Read := True; end if; Read_Spec := Next (Read_Spec); end loop; elsif Nm = Name_Write then Write_Spec := First (Parameter_Specifications (Specification (Item))); while Present (Write_Spec) loop Write_Type := Etype (Defining_Identifier (Write_Spec)); if Write_Type = Param_Type then Found_Write := True; end if; Write_Spec := Next (Write_Spec); end loop; end if; end if; Item := Next (Item); exit when Found_Read and then Found_Write; end loop; if not Found_Read or else not Found_Write then Error_Msg_N ("non-control parameter must have read/write in rci", Param_Spec); end if; end if; end if; -- Check next parameter in this subprogram Param_Spec := Next (Param_Spec); Found_Read := False; Found_Write := False; end loop; <<Next_Subprogram>> Subprogram := Next_Elmt (Subprogram); end loop; -- Now this is an RCI unit access-to-class-wide-limited-private type -- declaration. Set the type entity to be Is_Remote_Call_Interface to -- optimize later checks by avoiding tree traversal to find out if this -- entity is inside an RCI unit. Set_Is_Remote_Call_Interface (T); end Validate_RCI_Access_Object_Type_Declaration; --------------------------------------------- -- Validate_RCI_Limited_Type_Declaration -- --------------------------------------------- procedure Validate_RCI_Limited_Type_Declaration (N : Node_Id) is begin -- The visible part of an RCI unit must not contain -- declaration of limited type (RM E.2.3(10)) if Inside_Remote_Call_Interface_Unit then -- Called from Analyze_Private_Type_Declaration. if Nkind (N) = N_Private_Type_Declaration and then Limited_Present (N) then Error_Msg_N ("limited type declaration not allowed in rci unit", N); -- Called from Analyze_Task_Type or Analyze_Protected_Type, -- caller check to see type name is from source before calling. else Error_Msg_N ("limited type declaration not allowed in rci unit", N); end if; end if; end Validate_RCI_Limited_Type_Declaration; --------------------------------------------- -- Validate_RCI_Nested_Generic_Declaration -- --------------------------------------------- procedure Validate_RCI_Nested_Generic_Declaration (N : Node_Id) is begin -- The visible part of an RCI unit must not contain -- a nested generic_declaration (RM E.2.3(11)) if Inside_Remote_Call_Interface_Unit and then Nkind (Parent (N)) /= N_Compilation_Unit then Error_Msg_N ("nested generic declaration not allowed in rci unit", N); end if; end Validate_RCI_Nested_Generic_Declaration; ----------------------------------------- -- Validate_RCI_Subprogram_Declaration -- ----------------------------------------- procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is K : Node_Kind := Nkind (N); Profile : List_Id; Id : Node_Id; Param_Spec : Node_Id; Param_Type : Entity_Id; Type_Decl : Node_Id; Item : Node_Id; Nm : Name_Id; Found_Read : Boolean := False; Found_Write : Boolean := False; Read_Spec : Node_Id; Read_Type : Entity_Id; Write_Spec : Node_Id; Write_Type : Entity_Id; begin -- The visible part of an RCI unit must not contain the declaration -- of a subprogram to which a pragma Inline applies RM E.2.3(12). -- There are two possible cases in which this procedure is called: -- 1. called from Analyze_Subprogram_Declaration. -- 2. called from Validate_Object_Declaration (access to subprogram). if not Inside_Remote_Call_Interface_Unit then return; end if; if K = N_Subprogram_Declaration then Profile := Parameter_Specifications (Specification (N)); if Is_Inlined (Defining_Unit_Simple_Name (Specification (N))) then Error_Msg_N ("inlined subprogram cannot be declared in rci unit", N); end if; elsif K = N_Object_Declaration then Id := Defining_Identifier (N); if Nkind (Id) = N_Defining_Identifier and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration and then Ekind (Etype (Id)) = E_Access_Subprogram_Type then Profile := Parameter_Specifications (Type_Definition (Parent (Etype (Id)))); else return; end if; end if; -- Iterate through the parameter specification list, checking that -- no access parameter and no limited type paramter in the list. if Present (Profile) then Param_Spec := First (Profile); while Present (Param_Spec) loop Param_Type := Etype (Defining_Identifier (Param_Spec)); Type_Decl := Parent (Param_Type); if Ekind (Param_Type) = E_Anonymous_Access_Type then if K = N_Subprogram_Declaration then -- Report error only if it is not generated by compiler if Comes_From_Source (Defining_Unit_Name (Specification (N))) then Error_Msg_N ("subprogram in rci unit cannot have access parameter", Param_Spec); end if; else Error_Msg_N ("subprogram in rci unit cannot have access parameter", N); end if; -- For limited private type parameter, we check only the -- private declaration and ignore full type declaration. elsif Is_Limited_Type (Param_Type) and then Nkind (Type_Decl) = N_Private_Type_Declaration then -- Limited types having user defined Read and Write -- attributes are not violation. RM E.2.3(13) -- Now traverse the rest of the declaration list, looking -- for Read and Write. Item := Next (Type_Decl); while Present (Item) loop if Nkind (Item) = N_Subprogram_Declaration and then Present (Parameter_Specifications (Specification (Item))) then Nm := Chars (Defining_Unit_Name (Specification (Item))); -- If name is read or write then iterate through list -- of parameter specifications, looking for a match -- in the target limited type. if Nm = Name_Read then Read_Spec := First (Parameter_Specifications (Specification (Item))); while Present (Read_Spec) loop Read_Type := Etype (Defining_Identifier (Read_Spec)); if Read_Type = Param_Type then Found_Read := True; end if; Read_Spec := Next (Read_Spec); end loop; elsif Nm = Name_Write then Write_Spec := First (Parameter_Specifications (Specification (Item))); while Present (Write_Spec) loop Write_Type := Etype (Defining_Identifier (Write_Spec)); if Write_Type = Param_Type then Found_Write := True; end if; Write_Spec := Next (Write_Spec); end loop; end if; end if; Item := Next (Item); exit when Found_Read and Found_Write; end loop; if Found_Read and then Found_Write then return; else if K = N_Subprogram_Declaration then Error_Msg_N ("limited parameter not allowed in rci unit", Param_Spec); else Error_Msg_N ("limited parameter not allowed in rci unit", N); end if; end if; end if; Param_Spec := Next (Param_Spec); Found_Read := False; Found_Write := False; end loop; end if; end Validate_RCI_Subprogram_Declaration; ----------------------------------------------- -- Validate_Remote_Access_To_Class_Wide_Type -- ----------------------------------------------- procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is K : constant Node_Kind := Nkind (N); PK : constant Node_Kind := Nkind (Parent (N)); E : Entity_Id; P : Node_Id; PtrT : Entity_Id; T : Entity_Id; Expr : Node_Id; begin -- This subprogram enforces the checks in (RM E.2.2(8)) for -- certain uses of class-wide limited private types. -- Storage_Pool and Storage_Size are not defined for such types -- -- The expected type of allocator must not not be such a type. -- The actual parameter of generic instantiation must not -- be such a type. -- On entry, there are four cases -- 1. called from sem_attr Analyze_Attribute where attribute -- name is either Storage_Pool or Storage_Size. -- 2. called from exp_ch4 Expand_N_Allocator -- 3. called from sem_ch12 Analyze_Associations -- 4. called from sem_ch4 Analyze_Explicit_Dereference if not Present (N) then return; end if; if K = N_Attribute_Reference then E := Etype (Prefix (N)); if Is_Remote_Access_To_Class_Wide_Type (E) then Error_Msg_N ("incorrect attribute of remote operand", N); return; end if; elsif K = N_Allocator then E := Etype (N); if Is_Remote_Access_To_Class_Wide_Type (E) then Error_Msg_N ("incorrect expected remote type of allocator", N); return; end if; elsif K = N_Identifier then E := Entity (N); if Is_Remote_Access_To_Class_Wide_Type (E) then Error_Msg_N ("incorrect remote type generic actual", N); return; end if; -- This subprogram also enforces the checks in E.2.2(13). -- A value of such type must not be explicitly dereferenced -- unless in a dispatching call. elsif K = N_Explicit_Dereference then E := Etype (Prefix (N)); if Is_Remote_Access_To_Class_Wide_Type (E) and then PK /= N_Procedure_Call_Statement and then PK /= N_Function_Call then -- The following is to let the compiler generated tags check -- pass through without error message. This is a bit kludgy -- isn't there some better way of making this exclusion ??? if (PK = N_Selected_Component and then Present (Parent (Parent (N))) and then Nkind (Parent (Parent (N))) = N_Op_Ne) or else (PK = N_Unchecked_Type_Conversion and then Present (Parent (Parent (N))) and then Nkind (Parent (Parent (N))) = N_Selected_Component) then return; end if; -- The following is to let the compiler generated membership -- check and type conversion pass through without error message. if (PK = N_Not_In and then Present (Parent (Parent (N))) and then Nkind (Parent (Parent (N))) = N_If_Statement) or else (PK = N_Indexed_Component and then Present (Parent (Parent (N))) and then Nkind (Parent (Parent (N))) = N_Selected_Component) then return; end if; Error_Msg_N ("incorrect remote type dereference", N); end if; end if; end Validate_Remote_Access_To_Class_Wide_Type; ------------------------------------------ -- Validate_Remote_Type_Type_Conversion -- ------------------------------------------ procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is S : constant Entity_Id := Etype (N); E : constant Entity_Id := Etype (Expression (N)); begin -- This test is required in the case where a conversion apears -- inside a normal package, it does not necessarily have to be -- inside an RCI, Remote_Types unit (RM E.2.2(9,12)). if Is_Remote_Access_To_Subprogram_Type (E) and then not Is_Remote_Access_To_Subprogram_Type (S) then Error_Msg_N ("incorrect conversion of remote operand", N); return; elsif Is_Remote_Access_To_Class_Wide_Type (E) and then not Is_Remote_Access_To_Class_Wide_Type (S) then Error_Msg_N ("incorrect conversion of remote operand", N); return; end if; end Validate_Remote_Type_Type_Conversion; ----------------------------------------- -- Validate_SP_Access_Object_Type_Decl -- ----------------------------------------- procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is Direct_Designated_Type : Entity_Id; function Has_Entry_Declarations (E : Entity_Id) return Boolean; -- Return true if the protected type designated by T has -- entry declarations. function Has_Entry_Declarations (E : Entity_Id) return Boolean is Ety : Entity_Id; begin if Nkind (Parent (E)) = N_Protected_Type_Declaration then Ety := First_Entity (E); while Present (Ety) loop if Ekind (Ety) = E_Entry then return True; end if; Ety := Next (Ety); end loop; end if; return False; end Has_Entry_Declarations; -- Start of processing for -- Validate_SP_Access_Object_Type_Decl begin -- We are called from Sem_Ch3.Analyze_Type_Declaration, and the -- Nkind of the given entity is N_Access_To_Object_Definition. if not Comes_From_Source (T) or else not Inside_Shared_Passive_Unit or else Inside_Subprogram_Task_Protected_Unit then return; end if; -- Check Shared Passive unit. It should not contain the declaration -- of an access-to-object type whose designated type is a class-wide -- type, task type or protected type with entry (RM E.2.1(7)). Direct_Designated_Type := Directly_Designated_Type (T); if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then Error_Msg_N ("invalid access-to-class-wide type in shared passive unit", T); return; elsif Ekind (Direct_Designated_Type) in Task_Kind then Error_Msg_N ("invalid access-to-task type in shared passive unit", T); return; elsif Ekind (Direct_Designated_Type) in Protected_Kind and then Has_Entry_Declarations (Direct_Designated_Type) then Error_Msg_N ("invalid access-to-protected type in shared passive unit", T); return; end if; end Validate_SP_Access_Object_Type_Decl; --------------------------------- -- Validate_Static_Object_Name -- --------------------------------- procedure Validate_Static_Object_Name (N : Node_Id) is function Assignment_Left_Hand_Side (N : Node_Id) return Boolean; -- Return True if N is on the left hand side of an assignment statement, -- or is the defining id in an object declaration. function Assignment_Left_Hand_Side (N : Node_Id) return Boolean is begin if (Nkind (Parent (N)) = N_Assignment_Statement and then N = Name (Parent (N))) or else (Nkind (Parent (N)) = N_Object_Declaration and then N = Defining_Identifier (Parent (N))) then return True; end if; return False; end Assignment_Left_Hand_Side; -- Start of processing for Validate_Static_Object_Name begin -- Filter out cases that default primary is in a record type component -- decl., record type discriminant specification or primary is a param. -- in a record type implicit init. procedure call. -- Initialization call of internal types. if Nkind (Parent (N)) = N_Procedure_Call_Statement then if Present (Parent (Parent (N))) and then Nkind (Parent (Parent (N))) = N_Freeze_Entity then return; end if; if Nkind (Name (Parent (N))) = N_Identifier and then not Comes_From_Source (Entity (Name (Parent (N)))) then return; end if; end if; if Inside_Preelaborated_Unit and then not Inside_Subprogram_Unit and then Comes_From_Source (Entity (N)) and then Nkind (Parent (N)) /= N_Component_Declaration and then Nkind (Parent (N)) /= N_Discriminant_Specification and then ((Ekind (Entity (N)) = E_Variable and then not Assignment_Left_Hand_Side (N)) or else (not Is_Static_Expression (N) and then Ekind (Entity (N)) = E_Constant)) then Error_Msg_N ("non-static object name in preelaborated unit", N); end if; end Validate_Static_Object_Name; end Sem_Dist;