X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch13.adb;h=9e552ec1118e324a7f1a43af10146fbf631e432c;hb=c41b3068e68d298654ba4430bb43fec8c720c82b;hp=0895eb686522ff39e9a6ac18c31fb6f27260e148;hpb=d7ed83a2b5686530848aafcab09b5278684972b7;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 0895eb68652..9e552ec1118 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- 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- -- @@ -46,6 +46,7 @@ with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Dim; use Sem_Dim; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; @@ -161,15 +162,15 @@ package body Sem_Ch13 is ---------------------------------------------- -- The following table collects unchecked conversions for validation. - -- Entries are made by Validate_Unchecked_Conversion and then the - -- call to Validate_Unchecked_Conversions does the actual error - -- checking and posting of warnings. The reason for this delayed - -- processing is to take advantage of back-annotations of size and - -- alignment values performed by the back end. + -- Entries are made by Validate_Unchecked_Conversion and then the call + -- to Validate_Unchecked_Conversions does the actual error checking and + -- posting of warnings. The reason for this delayed processing is to take + -- advantage of back-annotations of size and alignment values performed by + -- the back end. - -- Note: the reason we store a Source_Ptr value instead of a Node_Id - -- is that by the time Validate_Unchecked_Conversions is called, Sprint - -- will already have modified all Sloc values if the -gnatD option is set. + -- Note: the reason we store a Source_Ptr value instead of a Node_Id is + -- that by the time Validate_Unchecked_Conversions is called, Sprint will + -- already have modified all Sloc values if the -gnatD option is set. type UC_Entry is record Eloc : Source_Ptr; -- node used for posting warnings @@ -193,13 +194,13 @@ package body Sem_Ch13 is -- for X'Address use Expr - -- where Expr is of the form Y'Address or recursively is a reference - -- to a constant of either of these forms, and X and Y are entities of - -- objects, then if Y has a smaller alignment than X, that merits a - -- warning about possible bad alignment. The following table collects - -- address clauses of this kind. We put these in a table so that they - -- can be checked after the back end has completed annotation of the - -- alignments of objects, since we can catch more cases that way. + -- where Expr is of the form Y'Address or recursively is a reference to a + -- constant of either of these forms, and X and Y are entities of objects, + -- then if Y has a smaller alignment than X, that merits a warning about + -- possible bad alignment. The following table collects address clauses of + -- this kind. We put these in a table so that they can be checked after the + -- back end has completed annotation of the alignments of objects, since we + -- can catch more cases that way. type Address_Clause_Check_Record is record N : Node_Id; @@ -728,8 +729,9 @@ package body Sem_Ch13 is A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; - Eloc : Source_Ptr := Sloc (Expr); - -- Source location of expression, modified when we split PPC's + Eloc : Source_Ptr := No_Location; + -- Source location of expression, modified when we split PPC's. It + -- is set below when Expr is present. procedure Check_False_Aspect_For_Derived_Type; -- This procedure checks for the case of a false aspect for a @@ -804,6 +806,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- Set the source location of expression, used in the case of + -- a failed precondition/postcondition or invariant. Note that + -- the source location of the expression is not usually the best + -- choice here. For example, it gets located on the last AND + -- keyword in a chain of boolean expressiond AND'ed together. + -- It is best to put the message on the first character of the + -- assertion, which is the effect of the First_Node call here. + + if Present (Expr) then + Eloc := Sloc (First_Node (Expr)); + end if; + -- Check restriction No_Implementation_Aspect_Specifications if Impl_Defined_Aspects (A_Id) then @@ -876,6 +890,28 @@ package body Sem_Ch13 is end loop; end if; + -- Check some general restrictions on language defined aspects + + if not Impl_Defined_Aspects (A_Id) then + Error_Msg_Name_1 := Nam; + + -- Not allowed for renaming declarations + + if Nkind (N) in N_Renaming_Declaration then + Error_Msg_N + ("aspect % not allowed for renaming declaration", + Aspect); + end if; + + -- Not allowed for formal type declarations + + if Nkind (N) = N_Formal_Type_Declaration then + Error_Msg_N + ("aspect % not allowed for formal type declaration", + Aspect); + end if; + end if; + -- Copy expression for later processing by the procedures -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations] @@ -1028,23 +1064,24 @@ package body Sem_Ch13 is -- Aspects corresponding to attribute definition clauses - when Aspect_Address | - Aspect_Alignment | - Aspect_Bit_Order | - Aspect_Component_Size | - Aspect_External_Tag | - Aspect_Input | - Aspect_Machine_Radix | - Aspect_Object_Size | - Aspect_Output | - Aspect_Read | - Aspect_Size | - Aspect_Small | - Aspect_Storage_Pool | - Aspect_Storage_Size | - Aspect_Stream_Size | - Aspect_Value_Size | - Aspect_Write => + when Aspect_Address | + Aspect_Alignment | + Aspect_Bit_Order | + Aspect_Component_Size | + Aspect_External_Tag | + Aspect_Input | + Aspect_Machine_Radix | + Aspect_Object_Size | + Aspect_Output | + Aspect_Read | + Aspect_Size | + Aspect_Small | + Aspect_Simple_Storage_Pool | + Aspect_Storage_Pool | + Aspect_Storage_Size | + Aspect_Stream_Size | + Aspect_Value_Size | + Aspect_Write => -- Construct the attribute definition clause @@ -1089,6 +1126,21 @@ package body Sem_Ch13 is pragma Assert (not Delay_Required); + when Aspect_Synchronization => + + -- The aspect corresponds to pragma Implemented. + -- Construct the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => New_List ( + New_Occurrence_Of (E, Loc), + Relocate_Node (Expr)), + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Implemented)); + + pragma Assert (not Delay_Required); + -- Aspects corresponding to pragmas with two arguments, where -- the second argument is a local name referring to the entity, -- and the first argument is the aspect definition expression. @@ -1150,6 +1202,12 @@ package body Sem_Ch13 is Set_Is_Delayed_Aspect (Aspect); Set_Has_Default_Aspect (Base_Type (Entity (Ent))); + if Is_Scalar_Type (E) then + Set_Default_Aspect_Value (Entity (Ent), Expr); + else + Set_Default_Aspect_Component_Value (Entity (Ent), Expr); + end if; + when Aspect_Attach_Handler => Aitem := Make_Pragma (Loc, @@ -1231,8 +1289,13 @@ package body Sem_Ch13 is -- We do not do this for Pre'Class, since we have to put -- these conditions together in a complex OR expression - if Pname = Name_Postcondition - or else not Class_Present (Aspect) + -- We do not do this in ASIS mode, as ASIS relies on the + -- original node representing the complete expression, when + -- retrieving it through the source aspect table. + + if not ASIS_Mode + and then (Pname = Name_Postcondition + or else not Class_Present (Aspect)) then while Nkind (Expr) = N_And_Then loop Insert_After (Aspect, @@ -1368,6 +1431,10 @@ package body Sem_Ch13 is -- missing in cases like subtype X is Y, and we would not -- have a place to build the predicate function). + -- If the type is private, indicate that its completion + -- has a freeze node, because that is the one that will be + -- visible at freeze time. + Set_Has_Predicates (E); if Is_Private_Type (E) @@ -1375,6 +1442,7 @@ package body Sem_Ch13 is then Set_Has_Predicates (Full_View (E)); Set_Has_Delayed_Aspects (Full_View (E)); + Ensure_Freeze_Node (Full_View (E)); end if; Ensure_Freeze_Node (E); @@ -1385,6 +1453,7 @@ package body Sem_Ch13 is Args : List_Id; Comp_Expr : Node_Id; Comp_Assn : Node_Id; + New_Expr : Node_Id; begin Args := New_List; @@ -1401,9 +1470,19 @@ package body Sem_Ch13 is goto Continue; end if; + -- Make pragma expressions refer to the original aspect + -- expressions through the Original_Node link. This is used + -- in semantic analysis for ASIS mode, so that the original + -- expression also gets analyzed. + Comp_Expr := First (Expressions (Expr)); while Present (Comp_Expr) loop - Append (Relocate_Node (Comp_Expr), Args); + New_Expr := Relocate_Node (Comp_Expr); + Set_Original_Node (New_Expr, Comp_Expr); + Append + (Make_Pragma_Argument_Association (Sloc (Comp_Expr), + Expression => New_Expr), + Args); Next (Comp_Expr); end loop; @@ -1418,10 +1497,12 @@ package body Sem_Ch13 is goto Continue; end if; + New_Expr := Relocate_Node (Expression (Comp_Assn)); + Set_Original_Node (New_Expr, Expression (Comp_Assn)); Append (Make_Pragma_Argument_Association ( Sloc => Sloc (Comp_Assn), Chars => Chars (First (Choices (Comp_Assn))), - Expression => Relocate_Node (Expression (Comp_Assn))), + Expression => New_Expr), Args); Next (Comp_Assn); end loop; @@ -1445,6 +1526,15 @@ package body Sem_Ch13 is goto Continue; end; + + when Aspect_Dimension => + Analyze_Aspect_Dimension (N, Id, Expr); + goto Continue; + + when Aspect_Dimension_System => + Analyze_Aspect_Dimension_System (N, Id, Expr); + goto Continue; + end case; -- If a delay is required, we delay the freeze (not much point in @@ -1826,6 +1916,11 @@ package body Sem_Ch13 is ------------------------ procedure Check_One_Function (Subp : Entity_Id) is + Default_Element : constant Node_Id := + Find_Aspect + (Etype (First_Formal (Subp)), + Aspect_Iterator_Element); + begin if not Check_Primitive_Function (Subp) then Error_Msg_NE @@ -1833,6 +1928,20 @@ package body Sem_Ch13 is Subp, Ent); end if; + -- An indexing function must return either the default element of + -- the container, or a reference type. + + if Present (Default_Element) then + Analyze (Default_Element); + if Is_Entity_Name (Default_Element) + and then Covers (Entity (Default_Element), Etype (Subp)) + then + return; + end if; + end if; + + -- Otherwise the return type must be a reference type. + if not Has_Implicit_Dereference (Etype (Subp)) then Error_Msg_N ("function for indexing must return a reference type", Subp); @@ -1853,7 +1962,7 @@ package body Sem_Ch13 is else declare - I : Interp_Index; + I : Interp_Index; It : Interp; begin @@ -2048,11 +2157,27 @@ package body Sem_Ch13 is Set_Analyzed (N, True); end if; - -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in - -- CodePeer mode or Alfa mode, since they are not relevant in these - -- contexts). + -- Ignore some selected attributes in CodePeer mode since they are not + -- relevant in this context. - if Ignore_Rep_Clauses or CodePeer_Mode or Alfa_Mode then + if CodePeer_Mode then + case Id is + + -- Ignore Component_Size in CodePeer mode, to avoid changing the + -- internal representation of types by implicitly packing them. + + when Attribute_Component_Size => + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + + when others => + null; + end case; + end if; + + -- Process Ignore_Rep_Clauses option + + if Ignore_Rep_Clauses then case Id is -- The following should be ignored. They do not affect legality @@ -2072,11 +2197,7 @@ package body Sem_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); return; - -- We do not want too ignore 'Small in CodePeer_Mode or Alfa_Mode, - -- since it has an impact on the exact computations performed. - - -- Perhaps 'Small should also not be ignored by - -- Ignore_Rep_Clauses ??? + -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ??? when Attribute_Small => if Ignore_Rep_Clauses then @@ -2090,13 +2211,14 @@ package body Sem_Ch13 is -- legality, e.g. failing to provide a stream attribute for a -- type may make a program illegal. - when Attribute_External_Tag | - Attribute_Input | - Attribute_Output | - Attribute_Read | - Attribute_Storage_Pool | - Attribute_Storage_Size | - Attribute_Write => + when Attribute_External_Tag | + Attribute_Input | + Attribute_Output | + Attribute_Read | + Attribute_Simple_Storage_Pool | + Attribute_Storage_Pool | + Attribute_Storage_Size | + Attribute_Write => null; -- Other cases are errors ("attribute& cannot be set with @@ -2143,18 +2265,57 @@ package body Sem_Ch13 is U_Ent := Underlying_Type (Ent); end if; - -- Complete other routine error checks + -- Avoid cascaded error if Etype (Nam) = Any_Type then return; + -- Must be declared in current scope + elsif Scope (Ent) /= Current_Scope then Error_Msg_N ("entity must be declared in this scope", Nam); return; + -- Must not be a source renaming (we do have some cases where the + -- expander generates a renaming, and those cases are OK, in such + -- cases any attribute applies to the renamed object as well). + + elsif Is_Object (Ent) + and then Present (Renamed_Object (Ent)) + then + -- Case of renamed object from source, this is an error + + if Comes_From_Source (Renamed_Object (Ent)) then + Get_Name_String (Chars (N)); + Error_Msg_Strlen := Name_Len; + Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); + Error_Msg_N + ("~ clause not allowed for a renaming declaration " + & "(RM 13.1(6))", Nam); + return; + + -- For the case of a compiler generated renaming, the attribute + -- definition clause applies to the renamed object created by the + -- expander. The easiest general way to handle this is to create a + -- copy of the attribute definition clause for this object. + + else + Insert_Action (N, + Make_Attribute_Definition_Clause (Loc, + Name => + New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc), + Chars => Chars (N), + Expression => Duplicate_Subexpr (Expression (N)))); + end if; + + -- If no underlying entity, use entity itself, applies to some + -- previously detected error cases ??? + elsif No (U_Ent) then U_Ent := Ent; + -- Cannot specify for a subtype (exception Object/Value_Size) + elsif Is_Type (U_Ent) and then not Is_First_Subtype (U_Ent) and then Id /= Attribute_Object_Size @@ -2326,12 +2487,6 @@ package body Sem_Ch13 is then Error_Msg_N ("constant overlays a variable?", Expr); - elsif Present (Renamed_Object (U_Ent)) then - Error_Msg_N - ("address clause not allowed" - & " for a renaming declaration (RM 13.1(6))", Nam); - return; - -- Imported variables can have an address clause, but then -- the import is pretty meaningless except to suppress -- initializations, so we do not need such variables to @@ -2464,7 +2619,8 @@ package body Sem_Ch13 is -- Alignment attribute definition clause when Attribute_Alignment => Alignment : declare - Align : constant Uint := Get_Alignment_Value (Expr); + Align : constant Uint := Get_Alignment_Value (Expr); + Max_Align : constant Uint := UI_From_Int (Maximum_Alignment); begin FOnly := True; @@ -2480,7 +2636,20 @@ package body Sem_Ch13 is elsif Align /= No_Uint then Set_Has_Alignment_Clause (U_Ent); - Set_Alignment (U_Ent, Align); + + -- Tagged type case, check for attempt to set alignment to a + -- value greater than Max_Align, and reset if so. + + if Is_Tagged_Type (U_Ent) and then Align > Max_Align then + Error_Msg_N + ("?alignment for & set to Maximum_Aligment", Nam); + Set_Alignment (U_Ent, Max_Align); + + -- All other cases + + else + Set_Alignment (U_Ent, Align); + end if; -- For an array type, U_Ent is the first subtype. In that case, -- also set the alignment of the anonymous base type so that @@ -2996,7 +3165,7 @@ package body Sem_Ch13 is -- Storage_Pool attribute definition clause - when Attribute_Storage_Pool => Storage_Pool : declare + when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare Pool : Entity_Id; T : Entity_Id; @@ -3027,8 +3196,24 @@ package body Sem_Ch13 is return; end if; - Analyze_And_Resolve - (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + if Id = Attribute_Storage_Pool then + Analyze_And_Resolve + (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + + -- In the Simple_Storage_Pool case, we allow a variable of any + -- simple storage pool type, so we Resolve without imposing an + -- expected type. + + else + Analyze_And_Resolve (Expr); + + if not Present (Get_Rep_Pragma + (Etype (Expr), Name_Simple_Storage_Pool_Type)) + then + Error_Msg_N + ("expression must be of a simple storage pool type", Expr); + end if; + end if; if not Denotes_Variable (Expr) then Error_Msg_N ("storage pool must be a variable", Expr); @@ -3113,7 +3298,7 @@ package body Sem_Ch13 is Error_Msg_N ("incorrect reference to a Storage Pool", Expr); return; end if; - end Storage_Pool; + end; ------------------ -- Storage_Size -- @@ -3365,10 +3550,22 @@ package body Sem_Ch13 is -- No statements other than code statements, pragmas, and labels. -- Again we allow certain internally generated statements. + -- In Ada 2012, qualified expressions are names, and the code + -- statement is initially parsed as a procedure call. + Stmt := First (Statements (HSS)); while Present (Stmt) loop StmtO := Original_Node (Stmt); - if Comes_From_Source (StmtO) + + -- A procedure call transformed into a code statement is OK. + + if Ada_Version >= Ada_2012 + and then Nkind (StmtO) = N_Procedure_Call_Statement + and then Nkind (Name (StmtO)) = N_Qualified_Expression + then + null; + + elsif Comes_From_Source (StmtO) and then not Nkind_In (StmtO, N_Pragma, N_Label, N_Code_Statement) @@ -4607,6 +4804,14 @@ package body Sem_Ch13 is -- (this is an error that will be caught elsewhere); Append_To (Private_Decls, PBody); + + -- If the invariant appears on the full view of a type, the + -- analysis of the private part is complete, and we must + -- analyze the new body explicitly. + + if In_Private_Part (Current_Scope) then + Analyze (PBody); + end if; end if; end if; end Build_Invariant_Procedure; @@ -4880,6 +5085,12 @@ package body Sem_Ch13 is Set_Has_Predicates (SId); Set_Predicate_Function (Typ, SId); + -- The predicate function is shared between views of a type. + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Set_Predicate_Function (Full_View (Typ), SId); + end if; + Spec := Make_Function_Specification (Loc, Defining_Unit_Name => SId, @@ -5829,7 +6040,29 @@ package body Sem_Ch13 is -- All other cases else - Preanalyze_Spec_Expression (End_Decl_Expr, T); + -- In a generic context the aspect expressions have not been + -- preanalyzed, so do it now. There are no conformance checks + -- to perform in this case. + + if No (T) then + Check_Aspect_At_Freeze_Point (ASN); + return; + + -- The default values attributes may be defined in the private part, + -- and the analysis of the expression may take place when only the + -- partial view is visible. The expression must be scalar, so use + -- the full view to resolve. + + elsif (A_Id = Aspect_Default_Value + or else + A_Id = Aspect_Default_Component_Value) + and then Is_Private_Type (T) + then + Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); + else + Preanalyze_Spec_Expression (End_Decl_Expr, T); + end if; + Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr); end if; @@ -5932,6 +6165,13 @@ package body Sem_Ch13 is when Aspect_Small => T := Universal_Real; + -- For a simple storage pool, we have to retrieve the type of the + -- pool object associated with the aspect's corresponding attribute + -- definition clause. + + when Aspect_Simple_Storage_Pool => + T := Etype (Expression (Aspect_Rep_Item (ASN))); + when Aspect_Storage_Pool => T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); @@ -5966,11 +6206,12 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; - -- Suppress/Unsuppress/Warnings should never be delayed + -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed - when Aspect_Suppress | - Aspect_Unsuppress | - Aspect_Warnings => + when Aspect_Suppress | + Aspect_Unsuppress | + Aspect_Synchronization | + Aspect_Warnings => raise Program_Error; -- Pre/Post/Invariant/Predicate take boolean expressions @@ -5985,6 +6226,11 @@ package body Sem_Ch13 is Aspect_Static_Predicate | Aspect_Type_Invariant => T := Standard_Boolean; + + when Aspect_Dimension | + Aspect_Dimension_System => + raise Program_Error; + end case; -- Do the preanalyze call @@ -7694,12 +7940,21 @@ package body Sem_Ch13 is -- Start of processing for Rep_Item_Too_Late begin - -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported - -- types, which may be frozen if they appear in a representation clause - -- for a local type. + -- First make sure entity is not frozen (RM 13.1(9)) if Is_Frozen (T) + + -- Exclude imported types, which may be frozen if they appear in a + -- representation clause for a local type. + and then not From_With_Type (T) + + -- Exclude generated entitiesa (not coming from source). The common + -- case is when we generate a renaming which prematurely freezes the + -- renamed internal entity, but we still want to be able to set copies + -- of attribute values such as Size/Alignment. + + and then Comes_From_Source (T) then Too_Late; S := First_Subtype (T); @@ -8575,8 +8830,8 @@ package body Sem_Ch13 is Target := Ancestor_Subtype (Etype (Act_Unit)); -- If either type is generic, the instantiation happens within a generic - -- unit, and there is nothing to check. The proper check - -- will happen when the enclosing generic is instantiated. + -- unit, and there is nothing to check. The proper check will happen + -- when the enclosing generic is instantiated. if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then return; @@ -8674,9 +8929,8 @@ package body Sem_Ch13 is end if; -- If unchecked conversion to access type, and access type is declared - -- in the same unit as the unchecked conversion, then set the - -- No_Strict_Aliasing flag (no strict aliasing is implicit in this - -- situation). + -- in the same unit as the unchecked conversion, then set the flag + -- No_Strict_Aliasing (no strict aliasing is implicit here) if Is_Access_Type (Target) and then In_Same_Source_Unit (Target, N) @@ -8684,11 +8938,11 @@ package body Sem_Ch13 is Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); end if; - -- Generate N_Validate_Unchecked_Conversion node for back end in - -- case the back end needs to perform special validation checks. + -- Generate N_Validate_Unchecked_Conversion node for back end in case + -- the back end needs to perform special validation checks. - -- Shouldn't this be in Exp_Ch13, since the check only gets done - -- if we have full expansion and the back end is called ??? + -- Shouldn't this be in Exp_Ch13, since the check only gets done if we + -- have full expansion and the back end is called ??? Vnode := Make_Validate_Unchecked_Conversion (Sloc (N)); @@ -8717,8 +8971,8 @@ package body Sem_Ch13 is Source : constant Entity_Id := T.Source; Target : constant Entity_Id := T.Target; - Source_Siz : Uint; - Target_Siz : Uint; + Source_Siz : Uint; + Target_Siz : Uint; begin -- This validation check, which warns if we have unequal sizes for