X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch13.adb;h=9e552ec1118e324a7f1a43af10146fbf631e432c;hb=c41b3068e68d298654ba4430bb43fec8c720c82b;hp=2a1134f4e99161037863ef91f792c796f3a28669;hpb=d64221a7a6b103b403196406f93a591f586df2b4;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2a1134f4e99..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-2010, 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; @@ -73,11 +74,11 @@ package body Sem_Ch13 is -- Local Subprograms -- ----------------------- - procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); - -- This routine is called after setting the Esize of type entity Typ. - -- The purpose is to deal with the situation where an alignment has been - -- inherited from a derived type that is no longer appropriate for the - -- new Esize value. In this case, we reset the Alignment to unknown. + procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint); + -- This routine is called after setting one of the sizes of type entity + -- Typ to Size. The purpose is to deal with the situation of a derived + -- type whose inherited alignment is no longer appropriate for the new + -- size value. In this case, we reset the Alignment to unknown. procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ, @@ -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; @@ -235,8 +236,8 @@ package body Sem_Ch13 is -- Processing depends on version of Ada -- For Ada 95, we just renumber bits within a storage unit. We do the - -- same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83, - -- and are free to add this extension. + -- same for Ada 83 mode, since we recognize the Bit_Order attribute in + -- Ada 83, and are free to add this extension. if Ada_Version < Ada_2005 then Comp := First_Component_Or_Discriminant (R); @@ -440,14 +441,14 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := SSU; Error_Msg_F ("\and is not a multiple of Storage_Unit (^) " - & "('R'M 13.4.1(10))", + & "(RM 13.4.1(10))", First_Bit (CC)); else Error_Msg_Uint_1 := Fbit; Error_Msg_F ("\and first bit (^) is non-zero " - & "('R'M 13.4.1(10))", + & "(RM 13.4.1(10))", First_Bit (CC)); end if; end if; @@ -661,11 +662,11 @@ package body Sem_Ch13 is end if; end Adjust_Record_For_Reverse_Bit_Order; - -------------------------------------- - -- Alignment_Check_For_Esize_Change -- - -------------------------------------- + ------------------------------------- + -- Alignment_Check_For_Size_Change -- + ------------------------------------- - procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is + procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is begin -- If the alignment is known, and not set by a rep clause, and is -- inconsistent with the size being set, then reset it to unknown, @@ -674,11 +675,11 @@ package body Sem_Ch13 is if Known_Alignment (Typ) and then not Has_Alignment_Clause (Typ) - and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0 + and then Size mod (Alignment (Typ) * SSU) /= 0 then Init_Alignment (Typ); end if; - end Alignment_Check_For_Esize_Change; + end Alignment_Check_For_Size_Change; ----------------------------------- -- Analyze_Aspect_Specifications -- @@ -695,8 +696,8 @@ package body Sem_Ch13 is -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node -- The general processing involves building an attribute definition - -- clause or a pragma node that corresponds to the access type. Then - -- one of two things happens: + -- clause or a pragma node that corresponds to the aspect. Then one + -- of two things happens: -- If we are required to delay the evaluation of this aspect to the -- freeze point, we attach the corresponding pragma/attribute definition @@ -710,7 +711,7 @@ package body Sem_Ch13 is -- or attribute definition node in either case to activate special -- processing (e.g. not traversing the list of homonyms for inline). - Delay_Required : Boolean; + Delay_Required : Boolean := False; -- Set True if delay is required begin @@ -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,31 @@ 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 + Check_Restriction + (No_Implementation_Aspect_Specifications, Aspect); + end if; + + -- Check restriction No_Specification_Of_Aspect + + Check_Restriction_No_Specification_Of_Aspect (Aspect); + + -- Analyze this aspect + Set_Analyzed (Aspect); Set_Entity (Aspect, E); Ent := New_Occurrence_Of (E, Sloc (Id)); @@ -812,53 +839,78 @@ package body Sem_Ch13 is -- test allows duplicate Pre/Post's that we generate internally -- to escape being flagged here. - Anod := First (L); - while Anod /= Aspect loop - if Same_Aspect (A_Id, Get_Aspect_Id (Chars (Identifier (Anod)))) - and then Comes_From_Source (Aspect) - then - Error_Msg_Name_1 := Nam; - Error_Msg_Sloc := Sloc (Anod); + if No_Duplicates_Allowed (A_Id) then + Anod := First (L); + while Anod /= Aspect loop + if Same_Aspect + (A_Id, Get_Aspect_Id (Chars (Identifier (Anod)))) + and then Comes_From_Source (Aspect) + then + Error_Msg_Name_1 := Nam; + Error_Msg_Sloc := Sloc (Anod); - -- Case of same aspect specified twice + -- Case of same aspect specified twice - if Class_Present (Anod) = Class_Present (Aspect) then - if not Class_Present (Anod) then - Error_Msg_NE - ("aspect% for & previously given#", - Id, E); - else - Error_Msg_NE - ("aspect `%''Class` for & previously given#", - Id, E); - end if; + if Class_Present (Anod) = Class_Present (Aspect) then + if not Class_Present (Anod) then + Error_Msg_NE + ("aspect% for & previously given#", + Id, E); + else + Error_Msg_NE + ("aspect `%''Class` for & previously given#", + Id, E); + end if; - -- Case of Pre and Pre'Class both specified + -- Case of Pre and Pre'Class both specified - elsif Nam = Name_Pre then - if Class_Present (Aspect) then - Error_Msg_NE - ("aspect `Pre''Class` for & is not allowed here", - Id, E); - Error_Msg_NE - ("\since aspect `Pre` previously given#", - Id, E); + elsif Nam = Name_Pre then + if Class_Present (Aspect) then + Error_Msg_NE + ("aspect `Pre''Class` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre` previously given#", + Id, E); - else - Error_Msg_NE - ("aspect `Pre` for & is not allowed here", - Id, E); - Error_Msg_NE - ("\since aspect `Pre''Class` previously given#", - Id, E); + else + Error_Msg_NE + ("aspect `Pre` for & is not allowed here", + Id, E); + Error_Msg_NE + ("\since aspect `Pre''Class` previously given#", + Id, E); + end if; end if; + + -- Allowed case of X and X'Class both specified end if; - goto Continue; + Next (Anod); + 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; - Next (Anod); - end loop; + -- 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] @@ -901,7 +953,7 @@ package body Sem_Ch13 is -- Never need to delay for boolean aspects - Delay_Required := False; + pragma Assert (not Delay_Required); -- Library unit aspects. These are boolean aspects, but we -- have to do special things with the insertion, since the @@ -941,26 +993,95 @@ package body Sem_Ch13 is -- If not package declaration, no delay is required - Delay_Required := False; + pragma Assert (not Delay_Required); + + -- Aspects related to container iterators. These aspects denote + -- subprograms, and thus must be delayed. + + when Aspect_Constant_Indexing | + Aspect_Variable_Indexing => + + if not Is_Type (E) or else not Is_Tagged_Type (E) then + Error_Msg_N ("indexing applies to a tagged type", N); + end if; + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + Delay_Required := True; + Set_Is_Delayed_Aspect (Aspect); + + when Aspect_Default_Iterator | + Aspect_Iterator_Element => + + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + + Delay_Required := True; + Set_Is_Delayed_Aspect (Aspect); + + when Aspect_Implicit_Dereference => + if not Is_Type (E) + or else not Has_Discriminants (E) + then + Error_Msg_N + ("Aspect must apply to a type with discriminants", N); + goto Continue; + + else + declare + Disc : Entity_Id; + + begin + Disc := First_Discriminant (E); + while Present (Disc) loop + if Chars (Expr) = Chars (Disc) + and then Ekind (Etype (Disc)) = + E_Anonymous_Access_Type + then + Set_Has_Implicit_Dereference (E); + Set_Has_Implicit_Dereference (Disc); + goto Continue; + end if; + + Next_Discriminant (Disc); + end loop; + + -- Error if no proper access discriminant. + + Error_Msg_NE + ("not an access discriminant of&", Expr, E); + end; + + goto Continue; + end if; -- 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_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 @@ -975,7 +1096,8 @@ package body Sem_Ch13 is -- to take care of it right away. if Nkind_In (Expr, N_Integer_Literal, N_String_Literal) then - Delay_Required := False; + pragma Assert (not Delay_Required); + null; else Delay_Required := True; Set_Is_Delayed_Aspect (Aspect); @@ -1002,7 +1124,22 @@ package body Sem_Ch13 is -- We don't have to play the delay game here, since the only -- values are check names which don't get analyzed anyway. - Delay_Required := False; + 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, @@ -1024,7 +1161,7 @@ package body Sem_Ch13 is -- We don't have to play the delay game here, since the only -- values are ON/OFF which don't get analyzed anyway. - Delay_Required := False; + pragma Assert (not Delay_Required); -- Default_Value and Default_Component_Value aspects. These -- are specially handled because they have no corresponding @@ -1065,6 +1202,62 @@ 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, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Attach_Handler), + Pragma_Argument_Associations => + New_List (Ent, Relocate_Node (Expr))); + + Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); + + pragma Assert (not Delay_Required); + + when Aspect_Priority | + Aspect_Interrupt_Priority | + Aspect_Dispatching_Domain | + Aspect_CPU => + declare + Pname : Name_Id; + + begin + if A_Id = Aspect_Priority then + Pname := Name_Priority; + + elsif A_Id = Aspect_Interrupt_Priority then + Pname := Name_Interrupt_Priority; + + elsif A_Id = Aspect_CPU then + Pname := Name_CPU; + + else + Pname := Name_Dispatching_Domain; + end if; + + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pname), + Pragma_Argument_Associations => + New_List + (Make_Pragma_Argument_Association + (Sloc => Sloc (Id), + Expression => Relocate_Node (Expr)))); + + Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); + + pragma Assert (not Delay_Required); + end; + -- Aspects Pre/Post generate Precondition/Postcondition pragmas -- with a first argument that is the expression, and a second -- argument that is an informative message if the test fails. @@ -1086,21 +1279,32 @@ package body Sem_Ch13 is -- we generate separate Pre/Post aspects for the separate -- clauses. Since we allow multiple pragmas, there is no -- problem in allowing multiple Pre/Post aspects internally. + -- These should be treated in reverse order (B first and + -- A second) since they are later inserted just after N in + -- the order they are treated. This way, the pragma for A + -- ends up preceding the pragma for B, which may have an + -- importance for the error raised (either constraint error + -- or precondition error). -- 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, - Make_Aspect_Specification (Sloc (Right_Opnd (Expr)), + Make_Aspect_Specification (Sloc (Left_Opnd (Expr)), Identifier => Identifier (Aspect), - Expression => Relocate_Node (Right_Opnd (Expr)), + Expression => Relocate_Node (Left_Opnd (Expr)), Class_Present => Class_Present (Aspect), Split_PPC => True)); - Rewrite (Expr, Relocate_Node (Left_Opnd (Expr))); + Rewrite (Expr, Relocate_Node (Right_Opnd (Expr))); Eloc := Sloc (Expr); end loop; end if; @@ -1133,6 +1337,7 @@ package body Sem_Ch13 is end if; Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- For Pre/Post cases, insert immediately after the entity @@ -1163,6 +1368,10 @@ package body Sem_Ch13 is when Aspect_Invariant | Aspect_Type_Invariant => + -- Analysis of the pragma will verify placement legality: + -- an invariant must apply to a private type, or appear in + -- the private part of a spec and apply to a completion. + -- Construct the pragma Aitem := @@ -1186,6 +1395,7 @@ package body Sem_Ch13 is end if; Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); Set_Is_Delayed_Aspect (Aspect); -- For Invariant case, insert immediately after the entity @@ -1204,7 +1414,7 @@ package body Sem_Ch13 is Aspect_Static_Predicate => -- Construct the pragma (always a pragma Predicate, with - -- flags recording whether + -- flags recording whether it is static/dynamic). Aitem := Make_Pragma (Loc, @@ -1215,23 +1425,116 @@ package body Sem_Ch13 is Make_Identifier (Sloc (Id), Name_Predicate)); Set_From_Aspect_Specification (Aitem, True); - - -- Set special flags for dynamic/static cases - - if A_Id = Aspect_Dynamic_Predicate then - Set_From_Dynamic_Predicate (Aitem); - elsif A_Id = Aspect_Static_Predicate then - Set_From_Static_Predicate (Aitem); - end if; + Set_Corresponding_Aspect (Aitem, Aspect); -- Make sure we have a freeze node (it might otherwise be -- 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) + and then Present (Full_View (E)) + 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); Set_Is_Delayed_Aspect (Aspect); Delay_Required := True; + + when Aspect_Test_Case => declare + Args : List_Id; + Comp_Expr : Node_Id; + Comp_Assn : Node_Id; + New_Expr : Node_Id; + + begin + Args := New_List; + + if Nkind (Parent (N)) = N_Compilation_Unit then + Error_Msg_N + ("incorrect placement of aspect `Test_Case`", E); + goto Continue; + end if; + + if Nkind (Expr) /= N_Aggregate then + Error_Msg_NE + ("wrong syntax for aspect `Test_Case` for &", Id, E); + 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 + 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; + + Comp_Assn := First (Component_Associations (Expr)); + while Present (Comp_Assn) loop + if List_Length (Choices (Comp_Assn)) /= 1 + or else + Nkind (First (Choices (Comp_Assn))) /= N_Identifier + then + Error_Msg_NE + ("wrong syntax for aspect `Test_Case` for &", Id, E); + 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 => New_Expr), + Args); + Next (Comp_Assn); + end loop; + + -- Build the test-case pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Name_Test_Case), + Pragma_Argument_Associations => + Args); + + Set_From_Aspect_Specification (Aitem, True); + Set_Corresponding_Aspect (Aitem, Aspect); + Set_Is_Delayed_Aspect (Aspect); + + -- Insert immediately after the entity declaration + + Insert_After (N, Aitem); + + 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 @@ -1242,6 +1545,11 @@ package body Sem_Ch13 is if Delay_Required then if Present (Aitem) then Set_From_Aspect_Specification (Aitem, True); + + if Nkind (Aitem) = N_Pragma then + Set_Corresponding_Aspect (Aitem, Aspect); + end if; + Set_Is_Delayed_Aspect (Aitem); Set_Aspect_Rep_Item (Aspect, Aitem); end if; @@ -1255,6 +1563,10 @@ package body Sem_Ch13 is else Set_From_Aspect_Specification (Aitem, True); + if Nkind (Aitem) = N_Pragma then + Set_Corresponding_Aspect (Aitem, Aspect); + end if; + -- If this is a compilation unit, we will put the pragma in -- the Pragmas_After list of the N_Compilation_Unit_Aux node. @@ -1282,18 +1594,76 @@ package body Sem_Ch13 is -- Here if not compilation unit case else - -- For Pre/Post cases, insert immediately after the entity - -- declaration, since that is the required pragma placement. + case A_Id is - if A_Id in Pre_Post_Aspects then - Insert_After (N, Aitem); + -- For Pre/Post cases, insert immediately after the + -- entity declaration, since that is the required pragma + -- placement. - -- For all other cases, insert in sequence + when Pre_Post_Aspects => + Insert_After (N, Aitem); - else - Insert_After (Ins_Node, Aitem); - Ins_Node := Aitem; - end if; + -- For Priority aspects, insert into the task or + -- protected definition, which we need to create if it's + -- not there. The same applies to CPU and + -- Dispatching_Domain but only to tasks. + + when Aspect_Priority | + Aspect_Interrupt_Priority | + Aspect_Dispatching_Domain | + Aspect_CPU => + declare + T : Node_Id; -- the type declaration + L : List_Id; -- list of decls of task/protected + + begin + if Nkind (N) = N_Object_Declaration then + T := Parent (Etype (Defining_Identifier (N))); + else + T := N; + end if; + + if Nkind (T) = N_Protected_Type_Declaration + and then A_Id /= Aspect_Dispatching_Domain + and then A_Id /= Aspect_CPU + then + pragma Assert + (Present (Protected_Definition (T))); + + L := Visible_Declarations + (Protected_Definition (T)); + + elsif Nkind (T) = N_Task_Type_Declaration then + if No (Task_Definition (T)) then + Set_Task_Definition + (T, + Make_Task_Definition + (Sloc (T), + Visible_Declarations => New_List, + End_Label => Empty)); + end if; + + L := Visible_Declarations (Task_Definition (T)); + + else + raise Program_Error; + end if; + + Prepend (Aitem, To => L); + + -- Analyze rewritten pragma. Otherwise, its + -- analysis is done too late, after the task or + -- protected object has been created. + + Analyze (Aitem); + end; + + -- For all other cases, insert in sequence + + when others => + Insert_After (Ins_Node, Aitem); + Ins_Node := Aitem; + end case; end if; end if; end; @@ -1383,6 +1753,18 @@ package body Sem_Ch13 is -- and if so gives an error message. If there is a duplicate, True is -- returned, otherwise if there is no error, False is returned. + procedure Check_Indexing_Functions; + -- Check that the function in Constant_Indexing or Variable_Indexing + -- attribute has the proper type structure. If the name is overloaded, + -- check that all interpretations are legal. + + procedure Check_Iterator_Functions; + -- Check that there is a single function in Default_Iterator attribute + -- has the proper type structure. + + function Check_Primitive_Function (Subp : Entity_Id) return Boolean; + -- Common legality check for the previous two + ----------------------------------- -- Analyze_Stream_TSS_Definition -- ----------------------------------- @@ -1520,6 +1902,214 @@ package body Sem_Ch13 is end if; end Analyze_Stream_TSS_Definition; + ------------------------------ + -- Check_Indexing_Functions -- + ------------------------------ + + procedure Check_Indexing_Functions is + + procedure Check_One_Function (Subp : Entity_Id); + -- Check one possible interpretation + + ------------------------ + -- Check_One_Function -- + ------------------------ + + 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 + ("aspect Indexing requires a function that applies to type&", + 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); + end if; + end Check_One_Function; + + -- Start of processing for Check_Indexing_Functions + + begin + if In_Instance then + return; + end if; + + Analyze (Expr); + + if not Is_Overloaded (Expr) then + Check_One_Function (Entity (Expr)); + + else + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + + -- Note that analysis will have added the interpretation + -- that corresponds to the dereference. We only check the + -- subprogram itself. + + if Is_Overloadable (It.Nam) then + Check_One_Function (It.Nam); + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + end Check_Indexing_Functions; + + ------------------------------ + -- Check_Iterator_Functions -- + ------------------------------ + + procedure Check_Iterator_Functions is + Default : Entity_Id; + + function Valid_Default_Iterator (Subp : Entity_Id) return Boolean; + -- Check one possible interpretation for validity + + ---------------------------- + -- Valid_Default_Iterator -- + ---------------------------- + + function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + if not Check_Primitive_Function (Subp) then + return False; + else + Formal := First_Formal (Subp); + end if; + + -- False if any subsequent formal has no default expression + + Formal := Next_Formal (Formal); + while Present (Formal) loop + if No (Expression (Parent (Formal))) then + return False; + end if; + + Next_Formal (Formal); + end loop; + + -- True if all subsequent formals have default expressions + + return True; + end Valid_Default_Iterator; + + -- Start of processing for Check_Iterator_Functions + + begin + Analyze (Expr); + + if not Is_Entity_Name (Expr) then + Error_Msg_N ("aspect Iterator must be a function name", Expr); + end if; + + if not Is_Overloaded (Expr) then + if not Check_Primitive_Function (Entity (Expr)) then + Error_Msg_NE + ("aspect Indexing requires a function that applies to type&", + Entity (Expr), Ent); + end if; + + if not Valid_Default_Iterator (Entity (Expr)) then + Error_Msg_N ("improper function for default iterator", Expr); + end if; + + else + Default := Empty; + declare + I : Interp_Index; + It : Interp; + + begin + Get_First_Interp (Expr, I, It); + while Present (It.Nam) loop + if not Check_Primitive_Function (It.Nam) + or else not Valid_Default_Iterator (It.Nam) + then + Remove_Interp (I); + + elsif Present (Default) then + Error_Msg_N ("default iterator must be unique", Expr); + + else + Default := It.Nam; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + + if Present (Default) then + Set_Entity (Expr, Default); + Set_Is_Overloaded (Expr, False); + end if; + end if; + end Check_Iterator_Functions; + + ------------------------------- + -- Check_Primitive_Function -- + ------------------------------- + + function Check_Primitive_Function (Subp : Entity_Id) return Boolean is + Ctrl : Entity_Id; + + begin + if Ekind (Subp) /= E_Function then + return False; + end if; + + if No (First_Formal (Subp)) then + return False; + else + Ctrl := Etype (First_Formal (Subp)); + end if; + + if Ctrl = Ent + or else Ctrl = Class_Wide_Type (Ent) + or else + (Ekind (Ctrl) = E_Anonymous_Access_Type + and then + (Designated_Type (Ctrl) = Ent + or else Designated_Type (Ctrl) = Class_Wide_Type (Ent))) + then + null; + + else + return False; + end if; + + return True; + end Check_Primitive_Function; + ---------------------- -- Duplicate_Clause -- ---------------------- @@ -1567,6 +2157,24 @@ package body Sem_Ch13 is Set_Analyzed (N, True); end if; + -- Ignore some selected attributes in CodePeer mode since they are not + -- relevant in this context. + + 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 @@ -1584,26 +2192,33 @@ package body Sem_Ch13 is Attribute_Machine_Radix | Attribute_Object_Size | Attribute_Size | - Attribute_Small | Attribute_Stream_Size | Attribute_Value_Size => - Rewrite (N, Make_Null_Statement (Sloc (N))); return; + -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ??? + + when Attribute_Small => + if Ignore_Rep_Clauses then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return; + end if; + -- The following should not be ignored, because in the first place -- they are reasonably portable, and should not cause problems in -- compiling code from another target, and also they do affect -- 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 @@ -1650,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 @@ -1833,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 @@ -1971,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; @@ -1987,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 @@ -2128,6 +2790,46 @@ package body Sem_Ch13 is end if; end Component_Size_Case; + ----------------------- + -- Constant_Indexing -- + ----------------------- + + when Attribute_Constant_Indexing => + Check_Indexing_Functions; + + ---------------------- + -- Default_Iterator -- + ---------------------- + + when Attribute_Default_Iterator => Default_Iterator : declare + Func : Entity_Id; + + begin + if not Is_Tagged_Type (U_Ent) then + Error_Msg_N + ("aspect Default_Iterator applies to tagged type", Nam); + end if; + + Check_Iterator_Functions; + + Analyze (Expr); + + if not Is_Entity_Name (Expr) + or else Ekind (Entity (Expr)) /= E_Function + then + Error_Msg_N ("aspect Iterator must be a function", Expr); + else + Func := Entity (Expr); + end if; + + if No (First_Formal (Func)) + or else Etype (First_Formal (Func)) /= U_Ent + then + Error_Msg_NE + ("Default Iterator must be a primitive of&", Func, U_Ent); + end if; + end Default_Iterator; + ------------------ -- External_Tag -- ------------------ @@ -2168,6 +2870,17 @@ package body Sem_Ch13 is end if; end External_Tag; + -------------------------- + -- Implicit_Dereference -- + -------------------------- + + when Attribute_Implicit_Dereference => + + -- Legality checks already performed at the point of + -- the type declaration, aspect is not delayed. + + null; + ----------- -- Input -- ----------- @@ -2176,6 +2889,19 @@ package body Sem_Ch13 is Analyze_Stream_TSS_Definition (TSS_Stream_Input); Set_Has_Specified_Stream_Input (Ent); + ---------------------- + -- Iterator_Element -- + ---------------------- + + when Attribute_Iterator_Element => + Analyze (Expr); + + if not Is_Entity_Name (Expr) + or else not Is_Type (Entity (Expr)) + then + Error_Msg_N ("aspect Iterator_Element must be a type", Expr); + end if; + ------------------- -- Machine_Radix -- ------------------- @@ -2243,7 +2969,7 @@ package body Sem_Ch13 is Set_Esize (U_Ent, Size); Set_Has_Object_Size_Clause (U_Ent); - Alignment_Check_For_Esize_Change (U_Ent); + Alignment_Check_For_Size_Change (U_Ent, Size); end if; end Object_Size; @@ -2328,11 +3054,18 @@ package body Sem_Ch13 is if Is_Type (U_Ent) then Set_RM_Size (U_Ent, Size); - -- For scalar types, increase Object_Size to power of 2, but - -- not less than a storage unit in any case (i.e., normally + -- For elementary types, increase Object_Size to power of 2, + -- but not less than a storage unit in any case (normally -- this means it will be byte addressable). - if Is_Scalar_Type (U_Ent) then + -- For all other types, nothing else to do, we leave Esize + -- (object size) unset, the back end will set it from the + -- size and alignment in an appropriate manner. + + -- In both cases, we check whether the alignment must be + -- reset in the wake of the size change. + + if Is_Elementary_Type (U_Ent) then if Size <= System_Storage_Unit then Init_Esize (U_Ent, System_Storage_Unit); elsif Size <= 16 then @@ -2343,15 +3076,11 @@ package body Sem_Ch13 is Set_Esize (U_Ent, (Size + 63) / 64 * 64); end if; - -- For all other types, object size = value size. The - -- backend will adjust as needed. - + Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent)); else - Set_Esize (U_Ent, Size); + Alignment_Check_For_Size_Change (U_Ent, Size); end if; - Alignment_Check_For_Esize_Change (U_Ent); - -- For objects, set Esize only else @@ -2436,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; @@ -2467,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); @@ -2553,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 -- @@ -2698,6 +3443,13 @@ package body Sem_Ch13 is end if; end Value_Size; + ----------------------- + -- Variable_Indexing -- + ----------------------- + + when Attribute_Variable_Indexing => + Check_Indexing_Functions; + ----------- -- Write -- ----------- @@ -2798,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) @@ -2829,7 +3593,9 @@ package body Sem_Ch13 is Assoc : Node_Id; Choice : Node_Id; Val : Uint; - Err : Boolean := False; + + Err : Boolean := False; + -- Set True to avoid cascade errors and crashes on incorrect source code Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); @@ -2968,51 +3734,61 @@ package body Sem_Ch13 is Err := True; elsif Nkind (Choice) = N_Range then + -- ??? should allow zero/one element range here + Error_Msg_N ("range not allowed here", Choice); Err := True; else Analyze_And_Resolve (Choice, Enumtype); - if Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) - then - Error_Msg_N ("subtype name not allowed here", Choice); + if Error_Posted (Choice) then Err := True; - -- ??? should allow static subtype with zero/one entry + end if; - elsif Etype (Choice) = Base_Type (Enumtype) then - if not Is_Static_Expression (Choice) then - Flag_Non_Static_Expr - ("non-static expression used for choice!", Choice); + if not Err then + if Is_Entity_Name (Choice) + and then Is_Type (Entity (Choice)) + then + Error_Msg_N ("subtype name not allowed here", Choice); Err := True; - else - Elit := Expr_Value_E (Choice); + -- ??? should allow static subtype with zero/one entry - if Present (Enumeration_Rep_Expr (Elit)) then - Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); - Error_Msg_NE - ("representation for& previously given#", - Choice, Elit); + elsif Etype (Choice) = Base_Type (Enumtype) then + if not Is_Static_Expression (Choice) then + Flag_Non_Static_Expr + ("non-static expression used for choice!", Choice); Err := True; - end if; - Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); + else + Elit := Expr_Value_E (Choice); + + if Present (Enumeration_Rep_Expr (Elit)) then + Error_Msg_Sloc := + Sloc (Enumeration_Rep_Expr (Elit)); + Error_Msg_NE + ("representation for& previously given#", + Choice, Elit); + Err := True; + end if; - Expr := Expression (Assoc); - Val := Static_Integer (Expr); + Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); - if Val = No_Uint then - Err := True; + Expr := Expression (Assoc); + Val := Static_Integer (Expr); - elsif Val < Lo or else Hi < Val then - Error_Msg_N ("value outside permitted range", Expr); - Err := True; - end if; + if Val = No_Uint then + Err := True; - Set_Enumeration_Rep (Elit, Val); + elsif Val < Lo or else Hi < Val then + Error_Msg_N ("value outside permitted range", Expr); + Err := True; + end if; + + Set_Enumeration_Rep (Elit, Val); + end if; end if; end if; end if; @@ -3257,6 +4033,7 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Aspect_Specification and then Entity (Ritem) = E and then Is_Delayed_Aspect (Ritem) + and then Scope (E) = Current_Scope then Check_Aspect_At_Freeze_Point (Ritem); end if; @@ -3364,9 +4141,7 @@ package body Sem_Ch13 is -- This seems dubious, this destroys the source tree in a manner -- not detectable by ASIS ??? - if Operating_Mode = Check_Semantics - and then ASIS_Mode - then + if Operating_Mode = Check_Semantics and then ASIS_Mode then AtM_Nod := Make_Attribute_Definition_Clause (Loc, Name => New_Reference_To (Base_Type (Rectype), Loc), @@ -3559,7 +4334,7 @@ package body Sem_Ch13 is Lbit := Lbit + UI_From_Int (SSU) * Posit; if Has_Size_Clause (Rectype) - and then Esize (Rectype) <= Lbit + and then RM_Size (Rectype) <= Lbit then Error_Msg_N ("bit number out of range of specified size", @@ -4029,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; @@ -4176,10 +4959,15 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then - if From_Dynamic_Predicate (Ritem) then - Dynamic_Predicate_Present := True; - elsif From_Static_Predicate (Ritem) then - Static_Predicate_Present := Ritem; + if Present (Corresponding_Aspect (Ritem)) then + case Chars (Identifier (Corresponding_Aspect (Ritem))) is + when Name_Dynamic_Predicate => + Dynamic_Predicate_Present := True; + when Name_Static_Predicate => + Static_Predicate_Present := Ritem; + when others => + null; + end case; end if; -- Acquire arguments @@ -4190,9 +4978,14 @@ package body Sem_Ch13 is Arg1 := Get_Pragma_Arg (Arg1); Arg2 := Get_Pragma_Arg (Arg2); - -- See if this predicate pragma is for the current type + -- See if this predicate pragma is for the current type or for + -- its full view. A predicate on a private completion is placed + -- on the partial view beause this is the visible entity that + -- is frozen. - if Entity (Arg1) = Typ then + if Entity (Arg1) = Typ + or else Full_View (Entity (Arg1)) = Typ + then -- We have a match, this entry is for our subtype @@ -4292,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, @@ -5188,7 +5987,7 @@ package body Sem_Ch13 is Ident : constant Node_Id := Identifier (ASN); Freeze_Expr : constant Node_Id := Expression (ASN); - -- Preanalyzed expression from call to Check_Aspect_At_Freeze_Point + -- Expression from call to Check_Aspect_At_Freeze_Point End_Decl_Expr : constant Node_Id := Entity (Ident); -- Expression to be analyzed at end of declarations @@ -5217,10 +6016,53 @@ package body Sem_Ch13 is Analyze (End_Decl_Expr); Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + elsif A_Id = Aspect_Variable_Indexing or else + A_Id = Aspect_Constant_Indexing or else + A_Id = Aspect_Default_Iterator or else + A_Id = Aspect_Iterator_Element + then + -- Make type unfrozen before analysis, to prevent spurious errors + -- about late attributes. + + Set_Is_Frozen (Ent, False); + Analyze (End_Decl_Expr); + Analyze (Aspect_Rep_Item (ASN)); + Set_Is_Frozen (Ent, True); + + -- If the end of declarations comes before any other freeze + -- point, the Freeze_Expr is not analyzed: no check needed. + + Err := + Analyzed (Freeze_Expr) + and then not In_Instance + and then Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + -- 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; @@ -5281,6 +6123,15 @@ package body Sem_Ch13 is when Boolean_Aspects => raise Program_Error; + -- Test_Case aspect applies to entries and subprograms, hence should + -- never be delayed. + + when Aspect_Test_Case => + raise Program_Error; + + when Aspect_Attach_Handler => + T := RTE (RE_Interrupt_ID); + -- Default_Value is resolved with the type entity in question when Aspect_Default_Value => @@ -5299,14 +6150,32 @@ package body Sem_Ch13 is when Aspect_Bit_Order => T := RTE (RE_Bit_Order); + when Aspect_CPU => + T := RTE (RE_CPU_Range); + + when Aspect_Dispatching_Domain => + T := RTE (RE_Dispatching_Domain); + when Aspect_External_Tag => T := Standard_String; + when Aspect_Priority | Aspect_Interrupt_Priority => + T := Standard_Integer; + + 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)); - when - Aspect_Alignment | + when Aspect_Alignment | Aspect_Component_Size | Aspect_Machine_Radix | Aspect_Object_Size | @@ -5326,11 +6195,23 @@ package body Sem_Ch13 is Analyze (Expression (ASN)); return; - -- Suppress/Unsupress/Warnings should never be delayed + -- Same for Iterator aspects, where the expression is a function + -- name. Legality rules are checked separately. + + when Aspect_Constant_Indexing | + Aspect_Default_Iterator | + Aspect_Iterator_Element | + Aspect_Implicit_Dereference | + Aspect_Variable_Indexing => + Analyze (Expression (ASN)); + return; + + -- 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 @@ -5345,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 @@ -5976,7 +6862,7 @@ package body Sem_Ch13 is -- Check bit position out of range of specified size if Has_Size_Clause (Rectype) - and then Esize (Rectype) <= Lbit + and then RM_Size (Rectype) <= Lbit then Error_Msg_N ("bit number out of range of specified size", @@ -7002,7 +7888,7 @@ package body Sem_Ch13 is and then No (Underlying_Type (T)) and then (Nkind (N) /= N_Pragma - or else Get_Pragma_Id (N) /= Pragma_Import) + or else Get_Pragma_Id (N) /= Pragma_Import) then Error_Msg_N ("representation item must be after full type declaration", N); @@ -7054,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); @@ -7281,7 +8176,17 @@ package body Sem_Ch13 is and then Known_Component_Size (T2) and then Component_Size (T1) = Component_Size (T2) then - return True; + if VM_Target = No_VM then + return True; + + -- In VM targets the representation of arrays with aliased + -- components differs from arrays with non-aliased components + + else + return Has_Aliased_Components (Base_Type (T1)) + = + Has_Aliased_Components (Base_Type (T2)); + end if; end if; end if; @@ -7925,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; @@ -8024,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) @@ -8034,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)); @@ -8067,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