diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 88c0fc005fa..6a49bd565ca 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -43,6 +43,7 @@ with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; +with Sem_Warn; use Sem_Warn; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; @@ -92,19 +93,19 @@ package body Sem_Ch13 is -- the expression N is of the form of K'Address, then the entity that -- is associated with K is marked as volatile. - procedure New_Stream_Function + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; Subp : Entity_Id; Nam : TSS_Name_Type); - -- Create a function renaming of a given stream attribute to the - -- designated subprogram and then in the tagged case, provide this as - -- a primitive operation, or in the non-tagged case make an appropriate - -- TSS entry. Used for Input. This is more properly an expansion activity - -- than just semantics, but the presence of user-defined stream functions - -- for limited types is a legality check, which is why this takes place - -- here rather than in exp_ch13, where it was previously. Nam indicates - -- the name of the TSS function to be generated. + -- Create a subprogram renaming of a given stream attribute to the + -- designated subprogram and then in the tagged case, provide this as a + -- primitive operation, or in the non-tagged case make an appropriate TSS + -- entry. This is more properly an expansion activity than just semantics, + -- but the presence of user-defined stream functions for limited types is a + -- legality check, which is why this takes place here rather than in + -- exp_ch13, where it was previously. Nam indicates the name of the TSS + -- function to be generated. -- -- To avoid elaboration anomalies with freeze nodes, for untagged types -- we generate both a subprogram declaration and a subprogram renaming @@ -112,18 +113,6 @@ package body Sem_Ch13 is -- renaming_as_body. For tagged types, the specification is one of the -- primitive specs. - procedure New_Stream_Procedure - (N : Node_Id; - Ent : Entity_Id; - Subp : Entity_Id; - Nam : TSS_Name_Type; - Out_P : Boolean := False); - -- Create a procedure renaming of a given stream attribute to the - -- designated subprogram and then in the tagged case, provide this as - -- a primitive operation, or in the non-tagged case make an appropriate - -- TSS entry. Used for Read, Output, Write. Nam indicates the name of - -- the TSS procedure to be generated. - ---------------------------------------------- -- Table for Validate_Unchecked_Conversions -- ---------------------------------------------- @@ -322,7 +311,21 @@ package body Sem_Ch13 is Pnam := TSS (Base_Type (U_Ent), TSS_Nam); - if Present (Pnam) and then Has_Good_Profile (Pnam) then + -- If Pnam is present, it can be either inherited from an ancestor + -- type (in which case it is legal to redefine it for this type), or + -- be a previous definition of the attribute for the same type (in + -- which case it is illegal). + + -- In the first case, it will have been analyzed already, and we + -- can check that its profile does not match the expected profile + -- for a stream attribute of U_Ent. In the second case, either Pnam + -- has been analyzed (and has the expected profile), or it has not + -- been analyzed yet (case of a type that has not been frozen yet + -- and for which the stream attribute has been set using Set_TSS). + + if Present (Pnam) + and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) + then Error_Msg_Sloc := Sloc (Pnam); Error_Msg_Name_1 := Attr; Error_Msg_N ("% attribute already defined #", Nam); @@ -360,12 +363,7 @@ package body Sem_Ch13 is Set_Entity (Expr, Subp); Set_Etype (Expr, Etype (Subp)); - if TSS_Nam = TSS_Stream_Input then - New_Stream_Function (N, U_Ent, Subp, TSS_Nam); - else - New_Stream_Procedure (N, U_Ent, Subp, TSS_Nam, - Out_P => Is_Read); - end if; + New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); else Error_Msg_Name_1 := Attr; @@ -623,11 +621,14 @@ package body Sem_Ch13 is Nam); end if; - -- Entity has delayed freeze, so we will generate - -- an alignment check at the freeze point. + -- Entity has delayed freeze, so we will generate an + -- alignment check at the freeze point unless suppressed. - Set_Check_Address_Alignment - (N, not Range_Checks_Suppressed (U_Ent)); + if not Range_Checks_Suppressed (U_Ent) + and then not Alignment_Checks_Suppressed (U_Ent) + then + Set_Check_Address_Alignment (N); + end if; -- Kill the size check code, since we are not allocating -- the variable, it is somewhere else. @@ -1046,75 +1047,6 @@ package body Sem_Ch13 is end if; end Small; - ------------------ - -- Storage_Size -- - ------------------ - - -- Storage_Size attribute definition clause - - when Attribute_Storage_Size => Storage_Size : declare - Btype : constant Entity_Id := Base_Type (U_Ent); - Sprag : Node_Id; - - begin - if Is_Task_Type (U_Ent) then - Check_Restriction (No_Obsolescent_Features, N); - - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("storage size clause for task is an " & - "obsolescent feature ('R'M 'J.9)?", N); - Error_Msg_N - ("\use Storage_Size pragma instead?", N); - end if; - - FOnly := True; - end if; - - if not Is_Access_Type (U_Ent) - and then Ekind (U_Ent) /= E_Task_Type - then - Error_Msg_N ("storage size cannot be given for &", Nam); - - elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then - Error_Msg_N - ("storage size cannot be given for a derived access type", - Nam); - - elsif Has_Storage_Size_Clause (Btype) then - Error_Msg_N ("storage size already given for &", Nam); - - else - Analyze_And_Resolve (Expr, Any_Integer); - - if Is_Access_Type (U_Ent) then - - if Present (Associated_Storage_Pool (U_Ent)) then - Error_Msg_N ("storage pool already given for &", Nam); - return; - end if; - - if Compile_Time_Known_Value (Expr) - and then Expr_Value (Expr) = 0 - then - Set_No_Pool_Assigned (Btype); - end if; - - else -- Is_Task_Type (U_Ent) - Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); - - if Present (Sprag) then - Error_Msg_Sloc := Sloc (Sprag); - Error_Msg_N - ("Storage_Size already specified#", Nam); - return; - end if; - end if; - - Set_Has_Storage_Size_Clause (Btype); - end if; - end Storage_Size; - ------------------ -- Storage_Pool -- ------------------ @@ -1126,11 +1058,17 @@ package body Sem_Ch13 is T : Entity_Id; begin - if Ekind (U_Ent) /= E_Access_Type + if Ekind (U_Ent) = E_Access_Subprogram_Type then + Error_Msg_N + ("storage pool cannot be given for access-to-subprogram type", + Nam); + return; + + elsif Ekind (U_Ent) /= E_Access_Type and then Ekind (U_Ent) /= E_General_Access_Type then - Error_Msg_N ( - "storage pool can only be given for access types", Nam); + Error_Msg_N + ("storage pool can only be given for access types", Nam); return; elsif Is_Derived_Type (U_Ent) then @@ -1229,6 +1167,74 @@ package body Sem_Ch13 is end if; end Storage_Pool; + ------------------ + -- Storage_Size -- + ------------------ + + -- Storage_Size attribute definition clause + + when Attribute_Storage_Size => Storage_Size : declare + Btype : constant Entity_Id := Base_Type (U_Ent); + Sprag : Node_Id; + + begin + if Is_Task_Type (U_Ent) then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("storage size clause for task is an " & + "obsolescent feature ('R'M 'J.9)?", N); + Error_Msg_N + ("\use Storage_Size pragma instead?", N); + end if; + + FOnly := True; + end if; + + if not Is_Access_Type (U_Ent) + and then Ekind (U_Ent) /= E_Task_Type + then + Error_Msg_N ("storage size cannot be given for &", Nam); + + elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then + Error_Msg_N + ("storage size cannot be given for a derived access type", + Nam); + + elsif Has_Storage_Size_Clause (Btype) then + Error_Msg_N ("storage size already given for &", Nam); + + else + Analyze_And_Resolve (Expr, Any_Integer); + + if Is_Access_Type (U_Ent) then + if Present (Associated_Storage_Pool (U_Ent)) then + Error_Msg_N ("storage pool already given for &", Nam); + return; + end if; + + if Compile_Time_Known_Value (Expr) + and then Expr_Value (Expr) = 0 + then + Set_No_Pool_Assigned (Btype); + end if; + + else -- Is_Task_Type (U_Ent) + Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); + + if Present (Sprag) then + Error_Msg_Sloc := Sloc (Sprag); + Error_Msg_N + ("Storage_Size already specified#", Nam); + return; + end if; + end if; + + Set_Has_Storage_Size_Clause (Btype); + end if; + end Storage_Size; + ----------------- -- Stream_Size -- ----------------- @@ -1349,6 +1355,8 @@ package body Sem_Ch13 is return; end if; + Check_Code_Statement (N); + -- Make sure we appear in the handled statement sequence of a -- subprogram (RM 13.8(3)). @@ -2630,7 +2638,7 @@ package body Sem_Ch13 is when N_Null => return; - when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In => + when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test => Check_Expr_Constants (Left_Opnd (Nod)); Check_Expr_Constants (Right_Opnd (Nod)); @@ -3116,89 +3124,15 @@ package body Sem_Ch13 is return S; end Minimum_Size; - ------------------------- - -- New_Stream_Function -- - ------------------------- + --------------------------- + -- New_Stream_Subprogram -- + --------------------------- - procedure New_Stream_Function - (N : Node_Id; - Ent : Entity_Id; - Subp : Entity_Id; - Nam : TSS_Name_Type) - is - Loc : constant Source_Ptr := Sloc (N); - Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); - Subp_Id : Entity_Id; - Subp_Decl : Node_Id; - F : Entity_Id; - Etyp : Entity_Id; - - function Build_Spec return Node_Id; - -- Used for declaration and renaming declaration, so that this is - -- treated as a renaming_as_body. - - ---------------- - -- Build_Spec -- - ---------------- - - function Build_Spec return Node_Id is - begin - Subp_Id := Make_Defining_Identifier (Loc, Sname); - - return - Make_Function_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc)))), - - Result_Definition => - New_Reference_To (Etyp, Loc)); - end Build_Spec; - - -- Start of processing for New_Stream_Function - - begin - F := First_Formal (Subp); - Etyp := Etype (Subp); - - if not Is_Tagged_Type (Ent) then - Subp_Decl := - Make_Subprogram_Declaration (Loc, - Specification => Build_Spec); - Insert_Action (N, Subp_Decl); - end if; - - Subp_Decl := - Make_Subprogram_Renaming_Declaration (Loc, - Specification => Build_Spec, - Name => New_Reference_To (Subp, Loc)); - - if Is_Tagged_Type (Ent) then - Set_TSS (Base_Type (Ent), Subp_Id); - else - Insert_Action (N, Subp_Decl); - Copy_TSS (Subp_Id, Base_Type (Ent)); - end if; - end New_Stream_Function; - - -------------------------- - -- New_Stream_Procedure -- - -------------------------- - - procedure New_Stream_Procedure + procedure New_Stream_Subprogram (N : Node_Id; Ent : Entity_Id; Subp : Entity_Id; - Nam : TSS_Name_Type; - Out_P : Boolean := False) + Nam : TSS_Name_Type) is Loc : constant Source_Ptr := Sloc (N); Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); @@ -3207,6 +3141,14 @@ package body Sem_Ch13 is F : Entity_Id; Etyp : Entity_Id; + Defer_Declaration : constant Boolean := + Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); + -- For a tagged type, there is a declaration for each stream attribute + -- at the freeze point, and we must generate only a completion of this + -- declaration. We do the same for private types, because the full view + -- might be tagged. Otherwise we generate a declaration at the point of + -- the attribute definition clause. + function Build_Spec return Node_Id; -- Used for declaration and renaming declaration, so that this is -- treated as a renaming_as_body. @@ -3216,56 +3158,101 @@ package body Sem_Ch13 is ---------------- function Build_Spec return Node_Id is + Out_P : constant Boolean := (Nam = TSS_Stream_Read); + Formals : List_Id; + Spec : Node_Id; + T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc); + begin Subp_Id := Make_Defining_Identifier (Loc, Sname); - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp_Id, - Parameter_Specifications => - New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_S), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Reference_To ( - Designated_Type (Etype (F)), Loc))), + -- S : access Root_Stream_Type'Class - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_V), - Out_Present => Out_P, - Parameter_Type => - New_Reference_To (Etyp, Loc)))); + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Reference_To ( + Designated_Type (Etype (F)), Loc)))); + + if Nam = TSS_Stream_Input then + Spec := Make_Function_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals, + Result_Definition => T_Ref); + else + -- V : [out] T + + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Out_P, + Parameter_Type => T_Ref)); + + Spec := Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals); + end if; + + return Spec; end Build_Spec; - -- Start of processing for New_Stream_Procedure + -- Start of processing for New_Stream_Subprogram begin - F := First_Formal (Subp); - Etyp := Etype (Next_Formal (F)); + F := First_Formal (Subp); - if not Is_Tagged_Type (Ent) then + if Ekind (Subp) = E_Procedure then + Etyp := Etype (Next_Formal (F)); + else + Etyp := Etype (Subp); + end if; + + -- Prepare subprogram declaration and insert it as an action on the + -- clause node. The visibility for this entity is used to test for + -- visibility of the attribute definition clause (in the sense of + -- 8.3(23) as amended by AI-195). + + if not Defer_Declaration then Subp_Decl := Make_Subprogram_Declaration (Loc, Specification => Build_Spec); - Insert_Action (N, Subp_Decl); + + -- For a tagged type, there is always a visible declaration for each + -- stream TSS (it is a predefined primitive operation), and the for the + -- completion of this declaration occurs at the freeze point, which is + -- not always visible at places where the attribute definition clause is + -- visible. So, we create a dummy entity here for the purpose of + -- tracking the visibility of the attribute definition clause itself. + + else + Subp_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Sname, 'V')); + Subp_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); end if; + Insert_Action (N, Subp_Decl); + Set_Entity (N, Subp_Id); + Subp_Decl := Make_Subprogram_Renaming_Declaration (Loc, Specification => Build_Spec, Name => New_Reference_To (Subp, Loc)); - if Is_Tagged_Type (Ent) then + if Defer_Declaration then Set_TSS (Base_Type (Ent), Subp_Id); else Insert_Action (N, Subp_Decl); Copy_TSS (Subp_Id, Base_Type (Ent)); end if; - end New_Stream_Procedure; + end New_Stream_Subprogram; ------------------------ -- Rep_Item_Too_Early -- @@ -3273,8 +3260,7 @@ package body Sem_Ch13 is function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is begin - -- Cannot apply rep items that are not operational items - -- to generic types + -- Cannot apply non-operational rep items to generic types if Is_Operational_Item (N) then return False;