diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/exp_dist.adb | 17 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.adb | 71 | ||||
| -rw-r--r-- | gcc/ada/sem_dist.ads | 51 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 68 |
6 files changed, 122 insertions, 116 deletions
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index e1c69b7a8f1..f8f34b43752 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -152,11 +152,6 @@ package body Exp_Dist is pragma Warnings (Off, Get_Subprogram_Id); -- One homonym only is unreferenced (specific to the GARLIC version) - function Get_PCS_Name return PCS_Names; - -- Return the name of a literal of type - -- System.Partition_Interface.DSA_Implementation_Type - -- indicating what PCS is currently in use. - procedure Add_RAS_Dereference_TSS (N : Node_Id); -- Add a subprogram body for RAS Dereference TSS @@ -4785,18 +4780,6 @@ package body Exp_Dist is Selector_Name => Make_Identifier (Loc, Selector_Name)); end Make_Selected_Component; - ------------------ - -- Get_PCS_Name -- - ------------------ - - function Get_PCS_Name return PCS_Names is - PCS_Name : constant PCS_Names := - Chars (Entity (Expression - (Parent (RTE (RE_DSA_Implementation))))); - begin - return PCS_Name; - end Get_PCS_Name; - ----------------------- -- Get_Subprogram_Id -- ----------------------- diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 15a2fd1c86d..cfe0850b768 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -43,6 +43,7 @@ with Opt; use Opt; with Restrict; use Restrict; with Sem; use Sem; with Sem_Ch7; use Sem_Ch7; +with Sem_Dist; use Sem_Dist; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; @@ -838,20 +839,12 @@ package body Rtsfind is E = RE_Params_Stream_Type or else E = RE_Request_Access) + and then Get_PCS_Name = Name_No_DSA then - declare - DSA_Implementation : constant Entity_Id := - RTE (RE_DSA_Implementation); - begin - if Chars (Entity (Expression - (Parent (DSA_Implementation)))) = Name_No_DSA - then - Set_Standard_Error; - Write_Str ("distribution feature not supported"); - Write_Eol; - raise Unrecoverable_Error; - end if; - end; + Set_Standard_Error; + Write_Str ("distribution feature not supported"); + Write_Eol; + raise Unrecoverable_Error; end if; end Check_RPC; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index d8900263ba5..5f8de03efc1 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -50,6 +50,7 @@ with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch12; use Sem_Ch12; with Sem_Disp; use Sem_Disp; +with Sem_Dist; use Sem_Dist; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; @@ -3235,6 +3236,7 @@ package body Sem_Ch8 is if Comes_From_Source (N) and then Is_Remote_Access_To_Subprogram_Type (E) and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA then Rewrite (N, New_Occurrence_Of (Equivalent_Type (E), Sloc (N))); @@ -3540,7 +3542,7 @@ package body Sem_Ch8 is and then Chars (P) = Chars (Selector) then Id := S; - goto found; + goto Found; end if; end if; @@ -3610,10 +3612,16 @@ package body Sem_Ch8 is end if; end if; - <<found>> + <<Found>> if Comes_From_Source (N) and then Is_Remote_Access_To_Subprogram_Type (Id) + and then Present (Equivalent_Type (Id)) then + -- If we are not actually generating distribution code (i.e. + -- the current PCS is the dummy non-distributed version), then + -- the Equivalent_Type will be missing, and Id should be treated + -- as a regular access-to-subprogram type. + Id := Equivalent_Type (Id); Set_Chars (Selector, Chars (Id)); end if; diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index c0fccfdc92a..188190f05af 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -199,6 +199,18 @@ package body Sem_Dist is return End_String; end Full_Qualified_Name; + ------------------ + -- Get_PCS_Name -- + ------------------ + + function Get_PCS_Name return PCS_Names is + PCS_Name : constant PCS_Names := + Chars (Entity (Expression + (Parent (RTE (RE_DSA_Implementation))))); + begin + return PCS_Name; + end Get_PCS_Name; + ------------------------ -- Is_All_Remote_Call -- ------------------------ @@ -341,7 +353,7 @@ package body Sem_Dist is Remote_Subp := Entity (Prefix (N)); - if not Expander_Active then + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return; end if; @@ -429,6 +441,33 @@ package body Sem_Dist is 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 @@ -457,29 +496,7 @@ package body Sem_Dist is Null_Present => True, Component_List => Empty))); - Is_Degenerate := False; - Parameter := First (Parameter_Specifications (Type_Def)); - Parameters : 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 Parameters; - end if; - Next (Parameter); - end loop Parameters; - - 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. - - else + if not Is_Degenerate then Append_To (Vis_Decls, Make_Abstract_Subprogram_Declaration (Loc, Specification => Build_RAS_Primitive_Specification ( @@ -595,7 +612,7 @@ package body Sem_Dist is return; end if; - if not Expander_Active then + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return; end if; @@ -685,7 +702,7 @@ package body Sem_Dist is Target_Type : Entity_Id; begin - if not Expander_Active then + if not Expander_Active or else Get_PCS_Name = Name_No_DSA then return False; elsif Ekind (Typ) = E_Access_Subprogram_Type diff --git a/gcc/ada/sem_dist.ads b/gcc/ada/sem_dist.ads index 4acf872baf4..f6f59084730 100644 --- a/gcc/ada/sem_dist.ads +++ b/gcc/ada/sem_dist.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -26,15 +26,20 @@ -- Semantic processing for distribution annex facilities -with Types; use Types; +with Snames; use Snames; +with Types; use Types; package Sem_Dist is + function Get_PCS_Name return PCS_Names; + -- Return the name of a literal of type System.Partition_Interface. + -- DSA_Implementation_Type indicating what PCS is currently in use. + procedure Add_Stub_Constructs (N : Node_Id); -- Create the stubs constructs for a remote call interface package - -- specification or body or for a shared passive specification. For - -- caller stubs, expansion takes place directly in the specification and - -- no additional compilation unit is created. + -- specification or body or for a shared passive specification. For caller + -- stubs, expansion takes place directly in the specification and no + -- additional compilation unit is created. function Build_RAS_Primitive_Specification (Subp_Spec : Node_Id; @@ -59,35 +64,33 @@ package Sem_Dist is -- whose return type is New_Type. procedure Process_Remote_AST_Declaration (N : Node_Id); - -- Given N, an access to subprogram type declaration node in RCI or - -- remote types unit, build a new record (fat pointer) type declaration - -- using the old Defining_Identifier of N and a link to the old - -- declaration node N whose Defining_Identifier is changed. - -- We also construct declarations of two subprograms in the unit - -- specification which handle remote access to subprogram type - -- (fat pointer) dereference and the unit receiver that handles - -- remote calls (from remote access to subprogram type values.) + -- Given N, an access to subprogram type declaration node in RCI or remote + -- types unit, build a new record (fat pointer) type declaration using the + -- old Defining_Identifier of N and a link to the old declaration node N + -- whose Defining_Identifier is changed. We also construct declarations of + -- two subprograms in the unit specification which handle remote access to + -- subprogram type (fat pointer) dereference and the unit receiver that + -- handles remote calls (from remote access to subprogram type values.) function Remote_AST_E_Dereference (P : Node_Id) return Boolean; -- If the prefix of an explicit dereference is a record type that - -- represent the fat pointer for an Remote access to subprogram, in - -- the context of a call, rewrite the enclosing call node into a - -- remote call, the first actual of which is the fat pointer. Return - -- true if the context is correct and the transformation took place. + -- represent the fat pointer for an Remote access to subprogram, in the + -- context of a call, rewrite the enclosing call node into remote call, + -- the first actual of which is the fat pointer. Return true if the + -- context is correct and the transformation took place. function Remote_AST_I_Dereference (P : Node_Id) return Boolean; -- If P is a record type that represents the fat pointer for a remote - -- access to subprogram, and P is the prefix of a call, insert an - -- explicit dereference and perform the transformation described for - -- the previous function. + -- access to subprogram, and P is the prefix of a call, insert an explicit + -- dereference and perform the transformation described for the previous + -- function. function Remote_AST_Null_Value (N : Node_Id; Typ : Entity_Id) return Boolean; - -- If N is a null value and Typ a remote access to subprogram type, - -- this function will check if null needs to be replaced with an - -- aggregate and will return True in this case. Otherwise, it will - -- return False. + -- If N is a null value and Typ a remote access to subprogram type, this + -- function will check if null needs to be replaced with an aggregate and + -- will return True in this case. Otherwise, it will return False. function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id; -- Return the N_Package_Specification corresponding to a scope E diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index af752663422..90ee6f56c7c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -168,7 +168,7 @@ package body Sem_Res is -- by other node rewriting procedures. procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); - -- Resolve actuals of call, and add default expressions for missing ones. + -- Resolve actuals of call, and add default expressions for missing ones procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); -- Called from Resolve_Call, when the prefix denotes an entry or element @@ -182,7 +182,7 @@ package body Sem_Res is -- to the corresponding predefined operator, with suitable conversions. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); - -- Ditto, for unary operators (only arithmetic ones). + -- Ditto, for unary operators (only arithmetic ones) procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, @@ -371,14 +371,14 @@ package body Sem_Res is D : Node_Id; begin - -- Any use in a default expression is legal. + -- Any use in a default expression is legal if In_Default_Expression then null; elsif Nkind (PN) = N_Range then - -- Discriminant cannot be used to constrain a scalar type. + -- Discriminant cannot be used to constrain a scalar type P := Parent (PN); @@ -1320,7 +1320,7 @@ package body Sem_Res is Full_Analysis := Save_Full_Analysis; end Pre_Analyze_And_Resolve; - -- Version without context type. + -- Version without context type procedure Pre_Analyze_And_Resolve (N : Node_Id) is Save_Full_Analysis : constant Boolean := Full_Analysis; @@ -1534,17 +1534,9 @@ package body Sem_Res is Is_Remote : Boolean := True; begin - -- Check that Typ is a fat pointer with a reference to a RAS as - -- original access type. + -- Check that Typ is a remote access-to-subprogram type - if - (Ekind (Typ) = E_Access_Subprogram_Type - and then Present (Equivalent_Type (Typ))) - or else - (Ekind (Typ) = E_Record_Type - and then Present (Corresponding_Remote_Type (Typ))) - - then + if Is_Remote_Access_To_Subprogram_Type (Typ) then -- Prefix (N) must statically denote a remote subprogram -- declared in a package specification. @@ -1581,6 +1573,7 @@ package body Sem_Res is or else Attr = Attribute_Unchecked_Access or else Attr = Attribute_Unrestricted_Access) and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA then Check_Subtype_Conformant (New_Id => Entity (Prefix (N)), @@ -2020,7 +2013,7 @@ package body Sem_Res is elsif Nkind (Name (N)) = N_Selected_Component then - -- Protected operation: retrieve operation name. + -- Protected operation: retrieve operation name Subp_Name := Selector_Name (Name (N)); else @@ -2411,7 +2404,7 @@ package body Sem_Res is else Set_Parent (Actval, N); - -- See note above concerning aggregates. + -- See note above concerning aggregates if Nkind (Actval) = N_Aggregate and then Has_Discriminants (Etype (Actval)) @@ -3131,13 +3124,13 @@ package body Sem_Res is elsif Etype (N) = T and then B_Typ /= Universal_Fixed then - -- Not a mixed-mode operation. Resolve with context. + -- Not a mixed-mode operation, resolve with context Resolve (N, B_Typ); elsif Etype (N) = Any_Fixed then - -- N may itself be a mixed-mode operation, so use context type. + -- N may itself be a mixed-mode operation, so use context type Resolve (N, B_Typ); @@ -4512,7 +4505,7 @@ package body Sem_Res is if Nkind (Entry_Name) = N_Selected_Component then - -- Simple entry call. + -- Simple entry call Nam := Entity (Selector_Name (Entry_Name)); Obj := Prefix (Entry_Name); @@ -4520,7 +4513,7 @@ package body Sem_Res is else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); - -- Call to member of entry family. + -- Call to member of entry family Nam := Entity (Selector_Name (Prefix (Entry_Name))); Obj := Prefix (Prefix (Entry_Name)); @@ -4941,7 +4934,7 @@ package body Sem_Res is Array_Type := Designated_Type (Array_Type); end if; - -- If name was overloaded, set component type correctly now. + -- If name was overloaded, set component type correctly now Set_Etype (N, Component_Type (Array_Type)); @@ -5247,7 +5240,7 @@ package body Sem_Res is return; end if; - -- The null literal takes its type from the context. + -- The null literal takes its type from the context Set_Etype (N, Typ); end Resolve_Null; @@ -6347,11 +6340,14 @@ package body Sem_Res is and then (Etype (Right_Opnd (Operand)) = Universal_Real or else Etype (Left_Opnd (Operand)) = Universal_Real) then + -- Return if expression is ambiguous + if Unique_Fixed_Point_Type (N) = Any_Type then - return; -- expression is ambiguous. - else - -- If nothing else, the available fixed type is Duration. + return; + -- If nothing else, the available fixed type is Duration + + else Set_Etype (Operand, Standard_Duration); end if; @@ -6548,7 +6544,7 @@ package body Sem_Res is Opnd_Type : constant Entity_Id := Etype (Operand); begin - -- Resolve operand using its own type. + -- Resolve operand using its own type Resolve (Operand, Opnd_Type); Eval_Unchecked_Conversion (N); @@ -6770,7 +6766,11 @@ package body Sem_Res is Scop : Entity_Id; procedure Fixed_Point_Error; - -- If true ambiguity, give details. + -- If true ambiguity, give details + + ----------------------- + -- Fixed_Point_Error -- + ----------------------- procedure Fixed_Point_Error is begin @@ -6779,6 +6779,8 @@ package body Sem_Res is Error_Msg_NE ("\possible interpretation as}", N, T2); end Fixed_Point_Error; + -- Start of processing for Unique_Fixed_Point_Type + begin -- The operations on Duration are visible, so Duration is always a -- possible interpretation. @@ -6810,7 +6812,7 @@ package body Sem_Res is Scop := Scope (Scop); end loop; - -- Look for visible fixed type declarations in the context. + -- Look for visible fixed type declarations in the context Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop @@ -6896,15 +6898,15 @@ package body Sem_Res is Opnd_Type : Entity_Id) return Boolean is begin - -- Upward conversions are allowed (RM 4.6(22)). + -- Upward conversions are allowed (RM 4.6(22)) if Covers (Target_Type, Opnd_Type) or else Is_Ancestor (Target_Type, Opnd_Type) then return True; - -- Downward conversion are allowed if the operand is - -- is class-wide (RM 4.6(23)). + -- Downward conversion are allowed if the operand is class-wide + -- (RM 4.6(23)). elsif Is_Class_Wide_Type (Opnd_Type) and then Covers (Opnd_Type, Target_Type) @@ -7285,7 +7287,7 @@ package body Sem_Res is elsif Is_Tagged_Type (Target_Type) then return Valid_Tagged_Conversion (Target_Type, Opnd_Type); - -- Types derived from the same root type are convertible. + -- Types derived from the same root type are convertible elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then return True; |