URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_dist.adb] - Rev 801
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ D I S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- 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 3, 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 COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Einfo; use Einfo; with Errout; use Errout; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Nlists; use Nlists; with Nmake; use Nmake; with Namet; use Namet; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Sem_Dist is ----------------------- -- Local Subprograms -- ----------------------- procedure RAS_E_Dereference (Pref : Node_Id); -- Handles explicit dereference of Remote Access to Subprograms function Full_Qualified_Name (E : Entity_Id) return String_Id; -- returns the full qualified name of the entity in lower case ------------------------- -- Add_Stub_Constructs -- ------------------------- procedure Add_Stub_Constructs (N : Node_Id) is U : constant Node_Id := Unit (N); Spec : Entity_Id := Empty; Exp : Node_Id := U; -- Unit that will be expanded begin pragma Assert (Distribution_Stub_Mode /= No_Stubs); if Nkind (U) = N_Package_Declaration then Spec := Defining_Entity (Specification (U)); elsif Nkind (U) = N_Package_Body then Spec := Corresponding_Spec (U); else pragma Assert (Nkind (U) = N_Package_Instantiation); Exp := Instance_Spec (U); Spec := Defining_Entity (Specification (Exp)); end if; pragma Assert (Is_Shared_Passive (Spec) or else Is_Remote_Call_Interface (Spec)); if Distribution_Stub_Mode = Generate_Caller_Stub_Body then if Is_Shared_Passive (Spec) then null; elsif Nkind (U) = N_Package_Body then Error_Msg_N ("Specification file expected from command line", U); else Expand_Calling_Stubs_Bodies (Exp); end if; else if Is_Shared_Passive (Spec) then Build_Passive_Partition_Stub (Exp); else Expand_Receiving_Stubs_Bodies (Exp); end if; end if; end Add_Stub_Constructs; --------------------------------------- -- Build_RAS_Primitive_Specification -- --------------------------------------- function Build_RAS_Primitive_Specification (Subp_Spec : Node_Id; Remote_Object_Type : Node_Id) return Node_Id is Loc : constant Source_Ptr := Sloc (Subp_Spec); Primitive_Spec : constant Node_Id := Copy_Specification (Loc, Spec => Subp_Spec, New_Name => Name_uCall); Subtype_Mark_For_Self : Node_Id; begin if No (Parameter_Specifications (Primitive_Spec)) then Set_Parameter_Specifications (Primitive_Spec, New_List); end if; if Nkind (Remote_Object_Type) in N_Entity then Subtype_Mark_For_Self := New_Occurrence_Of (Remote_Object_Type, Loc); else Subtype_Mark_For_Self := Remote_Object_Type; end if; Prepend_To ( Parameter_Specifications (Primitive_Spec), Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_uS), Parameter_Type => Make_Access_Definition (Loc, Subtype_Mark => Subtype_Mark_For_Self))); -- Trick later semantic analysis into considering this operation as a -- primitive (dispatching) operation of tagged type Obj_Type. Set_Comes_From_Source ( Defining_Unit_Name (Primitive_Spec), True); return Primitive_Spec; end Build_RAS_Primitive_Specification; ------------------------- -- Full_Qualified_Name -- ------------------------- function Full_Qualified_Name (E : Entity_Id) return String_Id is Ent : Entity_Id := E; Parent_Name : String_Id := No_String; begin -- Deals properly with child units if Nkind (Ent) = N_Defining_Program_Unit_Name then Ent := Defining_Identifier (Ent); end if; -- Compute recursively the qualification (only "Standard" has no scope) if Present (Scope (Scope (Ent))) then Parent_Name := Full_Qualified_Name (Scope (Ent)); end if; -- Every entity should have a name except some expanded blocks. Do not -- bother about those. if Chars (Ent) = No_Name then return Parent_Name; end if; -- Add a period between Name and qualification if Parent_Name /= No_String then Start_String (Parent_Name); Store_String_Char (Get_Char_Code ('.')); else Start_String; end if; -- Generates the entity name in upper case Get_Name_String (Chars (Ent)); Set_Casing (All_Lower_Case); Store_String_Chars (Name_Buffer (1 .. Name_Len)); return End_String; end Full_Qualified_Name; ------------------ -- Get_PCS_Name -- ------------------ function Get_PCS_Name return PCS_Names is begin return Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); end Get_PCS_Name; --------------------- -- Get_PCS_Version -- --------------------- function Get_PCS_Version return Int is PCS_Version_Entity : Entity_Id; PCS_Version : Int; begin if RTE_Available (RE_PCS_Version) then PCS_Version_Entity := RTE (RE_PCS_Version); pragma Assert (Ekind (PCS_Version_Entity) = E_Named_Integer); PCS_Version := UI_To_Int (Expr_Value (Constant_Value (PCS_Version_Entity))); else -- Case of System.Partition_Interface.PCS_Version not found: -- return a null version. PCS_Version := 0; end if; return PCS_Version; end Get_PCS_Version; ------------------------ -- Is_All_Remote_Call -- ------------------------ function Is_All_Remote_Call (N : Node_Id) return Boolean is Par : Node_Id; begin if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) and then Nkind (Name (N)) in N_Has_Entity and then Is_Remote_Call_Interface (Entity (Name (N))) and then Has_All_Calls_Remote (Scope (Entity (Name (N)))) and then Comes_From_Source (N) then Par := Parent (Entity (Name (N))); while Present (Par) and then (Nkind (Par) /= N_Package_Specification or else Is_Wrapper_Package (Defining_Entity (Par))) loop Par := Parent (Par); end loop; if Present (Par) then return not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par)); else return False; end if; else return False; end if; end Is_All_Remote_Call; --------------------------------- -- Is_RACW_Stub_Type_Operation -- --------------------------------- function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is Dispatching_Type : Entity_Id; begin case Ekind (Op) is when E_Function | E_Procedure => Dispatching_Type := Find_Dispatching_Type (Op); return Present (Dispatching_Type) and then Is_RACW_Stub_Type (Dispatching_Type) and then not Is_Internal (Op); when others => return False; end case; end Is_RACW_Stub_Type_Operation; --------------------------------- -- Is_Valid_Remote_Object_Type -- --------------------------------- function Is_Valid_Remote_Object_Type (E : Entity_Id) return Boolean is P : constant Node_Id := Parent (E); begin pragma Assert (Is_Tagged_Type (E)); -- Simple case: a limited private type if Nkind (P) = N_Private_Type_Declaration and then Is_Limited_Record (E) then return True; -- AI05-0060 (Binding Interpretation): A limited interface is a legal -- ancestor for the designated type of an RACW type. elsif Is_Limited_Record (E) and then Is_Limited_Interface (E) then return True; -- A generic tagged limited type is a valid candidate. Limitedness will -- be checked again on the actual at instantiation point. elsif Nkind (P) = N_Formal_Type_Declaration and then Ekind (E) = E_Record_Type_With_Private and then Is_Generic_Type (E) and then Is_Limited_Record (E) then return True; -- A private extension declaration is a valid candidate if its parent -- type is. elsif Nkind (P) = N_Private_Extension_Declaration then return Is_Valid_Remote_Object_Type (Etype (E)); else return False; end if; end Is_Valid_Remote_Object_Type; ------------------------------------ -- Package_Specification_Of_Scope -- ------------------------------------ function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is N : Node_Id; begin N := Parent (E); while Nkind (N) /= N_Package_Specification loop N := Parent (N); end loop; return N; end Package_Specification_Of_Scope; -------------------------- -- Process_Partition_ID -- -------------------------- procedure Process_Partition_Id (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Ety : Entity_Id; Get_Pt_Id : Node_Id; Get_Pt_Id_Call : Node_Id; Prefix_String : String_Id; Typ : constant Entity_Id := Etype (N); begin -- In case prefix is not a library unit entity, get the entity -- of library unit. Ety := Entity (Prefix (N)); while (Present (Scope (Ety)) and then Scope (Ety) /= Standard_Standard) and not Is_Child_Unit (Ety) loop Ety := Scope (Ety); end loop; -- Retrieve the proper function to call if Is_Remote_Call_Interface (Ety) then Get_Pt_Id := New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc); elsif Is_Shared_Passive (Ety) then Get_Pt_Id := New_Occurrence_Of (RTE (RE_Get_Passive_Partition_Id), Loc); else Get_Pt_Id := New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc); end if; -- Get and store the String_Id corresponding to the name of the -- library unit whose Partition_Id is needed. Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); Prefix_String := String_From_Name_Buffer; -- Build the function call which will replace the attribute if Is_Remote_Call_Interface (Ety) or else Is_Shared_Passive (Ety) then Get_Pt_Id_Call := Make_Function_Call (Loc, Name => Get_Pt_Id, Parameter_Associations => New_List (Make_String_Literal (Loc, Prefix_String))); else Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id); end if; -- Replace the attribute node by a conversion of the function call -- to the target type. Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call)); Analyze_And_Resolve (N, Typ); end Process_Partition_Id; ---------------------------------- -- Process_Remote_AST_Attribute -- ---------------------------------- procedure Process_Remote_AST_Attribute (N : Node_Id; New_Type : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); Remote_Subp : Entity_Id; Tick_Access_Conv_Call : Node_Id; Remote_Subp_Decl : Node_Id; RS_Pkg_Specif : Node_Id; RS_Pkg_E : Entity_Id; RAS_Type : Entity_Id := New_Type; Async_E : Entity_Id; All_Calls_Remote_E : Entity_Id; Attribute_Subp : Entity_Id; begin -- Check if we have to expand the access attribute Remote_Subp := Entity (Prefix (N)); if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return; end if; if Ekind (RAS_Type) /= E_Record_Type then RAS_Type := Equivalent_Type (RAS_Type); end if; Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access); pragma Assert (Present (Attribute_Subp)); Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then Remote_Subp := Corresponding_Spec (Remote_Subp_Decl); Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp); end if; RS_Pkg_Specif := Parent (Remote_Subp_Decl); RS_Pkg_E := Defining_Entity (RS_Pkg_Specif); Async_E := Boolean_Literals (Ekind (Remote_Subp) = E_Procedure and then Is_Asynchronous (Remote_Subp)); All_Calls_Remote_E := Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E)); Tick_Access_Conv_Call := Make_Function_Call (Loc, Name => New_Occurrence_Of (Attribute_Subp, Loc), Parameter_Associations => New_List ( Make_String_Literal (Loc, Strval => Full_Qualified_Name (RS_Pkg_E)), Build_Subprogram_Id (Loc, Remote_Subp), New_Occurrence_Of (Async_E, Loc), New_Occurrence_Of (All_Calls_Remote_E, Loc))); Rewrite (N, Tick_Access_Conv_Call); Analyze_And_Resolve (N, RAS_Type); end Process_Remote_AST_Attribute; ------------------------------------ -- Process_Remote_AST_Declaration -- ------------------------------------ procedure Process_Remote_AST_Declaration (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); User_Type : constant Node_Id := Defining_Identifier (N); Scop : constant Entity_Id := Scope (User_Type); Is_RCI : constant Boolean := Is_Remote_Call_Interface (Scop); Is_RT : constant Boolean := Is_Remote_Types (Scop); Type_Def : constant Node_Id := Type_Definition (N); Parameter : Node_Id; Is_Degenerate : Boolean; -- True iff this RAS has an access formal parameter (see -- Exp_Dist.Add_RAS_Dereference_TSS for details). Subpkg : constant Entity_Id := Make_Temporary (Loc, 'S'); Subpkg_Decl : Node_Id; Subpkg_Body : Node_Id; Vis_Decls : constant List_Id := New_List; Priv_Decls : constant List_Id := New_List; Obj_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'R')); Full_Obj_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars (Obj_Type)); RACW_Type : constant Entity_Id := Make_Defining_Identifier (Loc, New_External_Name (Chars (User_Type), 'P')); Fat_Type : constant Entity_Id := Make_Defining_Identifier (Loc, Chars (User_Type)); Fat_Type_Decl : Node_Id; begin Is_Degenerate := False; Parameter := First (Parameter_Specifications (Type_Def)); while Present (Parameter) loop if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then Error_Msg_N ("formal parameter& has anonymous access type?", Defining_Identifier (Parameter)); Is_Degenerate := True; exit; end if; Next (Parameter); end loop; if Is_Degenerate then Error_Msg_NE ("remote access-to-subprogram type& can only be null?", Defining_Identifier (Parameter), User_Type); -- The only legal value for a RAS with a formal parameter of an -- anonymous access type is null, because it cannot be subtype- -- conformant with any legal remote subprogram declaration. In this -- case, we cannot generate a corresponding primitive operation. end if; if Get_PCS_Name = Name_No_DSA then return; end if; -- The tagged private type, primitive operation and RACW type associated -- with a RAS need to all be declared in a subpackage of the one that -- contains the RAS declaration, because the primitive of the object -- type, and the associated primitive of the stub type, need to be -- dispatching operations of these types, and the profile of the RAS -- might contain tagged types declared in the same scope. Append_To (Vis_Decls, Make_Private_Type_Declaration (Loc, Defining_Identifier => Obj_Type, Abstract_Present => True, Tagged_Present => True, Limited_Present => True)); Append_To (Priv_Decls, Make_Full_Type_Declaration (Loc, Defining_Identifier => Full_Obj_Type, Type_Definition => Make_Record_Definition (Loc, Abstract_Present => True, Tagged_Present => True, Limited_Present => True, Null_Present => True, Component_List => Empty))); -- Trick semantic analysis into swapping the public and full view when -- freezing the public view. Set_Comes_From_Source (Full_Obj_Type, True); if not Is_Degenerate then Append_To (Vis_Decls, Make_Abstract_Subprogram_Declaration (Loc, Specification => Build_RAS_Primitive_Specification ( Subp_Spec => Type_Def, Remote_Object_Type => Obj_Type))); end if; Append_To (Vis_Decls, Make_Full_Type_Declaration (Loc, Defining_Identifier => RACW_Type, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Subtype_Indication => Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Obj_Type, Loc), Attribute_Name => Name_Class)))); Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); Subpkg_Decl := Make_Package_Declaration (Loc, Make_Package_Specification (Loc, Defining_Unit_Name => Subpkg, Visible_Declarations => Vis_Decls, Private_Declarations => Priv_Decls, End_Label => New_Occurrence_Of (Subpkg, Loc))); Set_Is_Remote_Call_Interface (Subpkg, Is_RCI); Set_Is_Remote_Types (Subpkg, Is_RT); Insert_After_And_Analyze (N, Subpkg_Decl); -- Generate package body to receive RACW calling stubs -- Note: Analyze_Declarations has an absolute requirement that the -- declaration list be non-empty, so provide dummy null statement here. Subpkg_Body := Make_Package_Body (Loc, Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subpkg)), Declarations => New_List (Make_Null_Statement (Loc))); Insert_After_And_Analyze (Subpkg_Decl, Subpkg_Body); -- Many parts of the analyzer and expander expect -- that the fat pointer type used to implement remote -- access to subprogram types be a record. -- Note: The structure of this type must be kept consistent -- with the code generated by Remote_AST_Null_Value for the -- corresponding 'null' expression. Fat_Type_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Fat_Type, 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_Ras), Component_Definition => Make_Component_Definition (Loc, Aliased_Present => False, Subtype_Indication => New_Occurrence_Of (RACW_Type, Loc))))))); Set_Equivalent_Type (User_Type, Fat_Type); Set_Corresponding_Remote_Type (Fat_Type, User_Type); Insert_After_And_Analyze (Subpkg_Body, Fat_Type_Decl); -- The reason we suppress the initialization procedure is that we know -- that no initialization is required (even if Initialize_Scalars mode -- is active), and there are order of elaboration problems if we do try -- to generate an init proc for this created record type. Set_Suppress_Initialization (Fat_Type); if Expander_Active then Add_RAST_Features (Parent (User_Type)); end if; end Process_Remote_AST_Declaration; ----------------------- -- RAS_E_Dereference -- ----------------------- procedure RAS_E_Dereference (Pref : Node_Id) is Loc : constant Source_Ptr := Sloc (Pref); Call_Node : Node_Id; New_Type : constant Entity_Id := Etype (Pref); Explicit_Deref : constant Node_Id := Parent (Pref); Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref); Deref_Proc : Entity_Id; Params : List_Id; begin if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then Params := Parameter_Associations (Deref_Subp_Call); if Present (Params) then Prepend (Pref, Params); else Params := New_List (Pref); end if; elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then Params := Expressions (Deref_Subp_Call); if Present (Params) then Prepend (Pref, Params); else Params := New_List (Pref); end if; else -- Context is not a call return; end if; if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return; end if; Deref_Proc := TSS (New_Type, TSS_RAS_Dereference); pragma Assert (Present (Deref_Proc)); if Ekind (Deref_Proc) = E_Function then Call_Node := Make_Function_Call (Loc, Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); else Call_Node := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Deref_Proc, Loc), Parameter_Associations => Params); end if; Rewrite (Deref_Subp_Call, Call_Node); Analyze (Deref_Subp_Call); end RAS_E_Dereference; ------------------------------ -- Remote_AST_E_Dereference -- ------------------------------ function Remote_AST_E_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); begin -- Perform the changes only on original dereferences, and only if -- we are generating code. if Comes_From_Source (P) and then Is_Record_Type (ET) and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) and then Nkind_In (Parent (Parent (P)), N_Procedure_Call_Statement, N_Indexed_Component) and then Expander_Active then RAS_E_Dereference (P); return True; else return False; end if; end Remote_AST_E_Dereference; ------------------------------ -- Remote_AST_I_Dereference -- ------------------------------ function Remote_AST_I_Dereference (P : Node_Id) return Boolean is ET : constant Entity_Id := Etype (P); Deref : Node_Id; begin if Comes_From_Source (P) and then (Is_Remote_Call_Interface (ET) or else Is_Remote_Types (ET)) and then Present (Corresponding_Remote_Type (ET)) and then Ekind (Entity (P)) /= E_Function then Deref := Make_Explicit_Dereference (Sloc (P), Prefix => Relocate_Node (P)); Rewrite (P, Deref); Set_Etype (P, ET); RAS_E_Dereference (Prefix (P)); return True; end if; return False; end Remote_AST_I_Dereference; --------------------------- -- Remote_AST_Null_Value -- --------------------------- function Remote_AST_Null_Value (N : Node_Id; Typ : Entity_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); Target_Type : Entity_Id; begin if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return False; elsif Ekind (Typ) = E_Access_Subprogram_Type and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ)) and then Comes_From_Source (N) and then Expander_Active then -- Any null that comes from source and is of the RAS type must -- be expanded, except if expansion is not active (nothing -- gets expanded into the equivalent record type). Target_Type := Equivalent_Type (Typ); elsif Ekind (Typ) = E_Record_Type and then Present (Corresponding_Remote_Type (Typ)) then -- This is a record type representing a RAS type, this must be -- expanded. Target_Type := Typ; else -- We do not have to handle this case return False; end if; Rewrite (N, Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, Choices => New_List (Make_Identifier (Loc, Name_Ras)), Expression => Make_Null (Loc))))); Analyze_And_Resolve (N, Target_Type); return True; end Remote_AST_Null_Value; end Sem_Dist;
Go to most recent revision | Compare with Previous | Blame | View Log