X-Git-Url: https://git.libre-soc.org/?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch13.adb;h=15862442175cbdf0af0c334f2b8197bd9d69a47d;hb=8b58a060443a7a04f2e1fa854ec2f9fac1a7ff1c;hp=c21468ffa2e4bba4e69fbfd91275aadd9105e885;hpb=c5a26133df8575533bc97def6e76bf66bec7f91a;p=gcc.git diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c21468ffa2e..15862442175 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -43,6 +44,7 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; @@ -50,6 +52,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; @@ -82,15 +85,17 @@ package body Sem_Ch13 is -- 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); + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ, - -- then either there are pragma Invariant entries on the rep chain for the + -- then either there are pragma Predicate entries on the rep chain for the -- type (note that Predicate aspects are converted to pragma Predicate), or -- there are inherited aspects from a parent type, or ancestor subtypes. -- This procedure builds the spec and body for the Predicate function that -- tests these predicates. N is the freeze node for the type. The spec of -- the function is inserted before the freeze node, and the body of the - -- function is inserted after the freeze node. + -- function is inserted after the freeze node. If the predicate expression + -- has at least one Raise_Expression, then this procedure also builds the + -- M version of the predicate function for use in membership tests. procedure Build_Static_Predicate (Typ : Entity_Id; @@ -107,6 +112,13 @@ package body Sem_Ch13 is -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as -- a canonicalized membership operation. + procedure Freeze_Entity_Checks (N : Node_Id); + -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity + -- to generate appropriate semantic checks that are delayed until this + -- point (they had to be delayed this long for cases of delayed aspects, + -- e.g. analysis of statically predicated subtypes in choices, for which + -- we have to be sure the subtypes in question are frozen before checking. + function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -253,9 +265,7 @@ package body Sem_Ch13 is -- is important, since otherwise if there are record subtypes, we -- could reverse the bits once for each subtype, which is wrong. - if Present (CC) - and then Ekind (R) = E_Record_Type - then + if Present (CC) and then Ekind (R) = E_Record_Type then declare CFB : constant Uint := Component_Bit_Offset (Comp); CSZ : constant Uint := Esize (Comp); @@ -281,16 +291,16 @@ package body Sem_Ch13 is then Error_Msg_N ("multi-byte field specified with non-standard" - & " Bit_Order?", CLC); + & " Bit_Order??", CLC); if Bytes_Big_Endian then Error_Msg_N ("bytes are not reversed " - & "(component is big-endian)?", CLC); + & "(component is big-endian)??", CLC); else Error_Msg_N ("bytes are not reversed " - & "(component is little-endian)?", CLC); + & "(component is little-endian)??", CLC); end if; -- Do not allow non-contiguous field @@ -316,14 +326,14 @@ package body Sem_Ch13 is and then Warn_On_Reverse_Bit_Order then Error_Msg_N - ("?Bit_Order clause does not affect " & - "byte ordering", Pos); + ("Bit_Order clause does not affect " & + "byte ordering?V?", Pos); Error_Msg_Uint_1 := Intval (Pos) + Intval (FB) / System_Storage_Unit; Error_Msg_N - ("?position normalized to ^ before bit " & - "order interpreted", Pos); + ("position normalized to ^ before bit " & + "order interpreted?V?", Pos); end if; -- Here is where we fix up the Component_Bit_Offset value @@ -392,10 +402,8 @@ package body Sem_Ch13 is if Present (CC) then declare - Fbit : constant Uint := - Static_Integer (First_Bit (CC)); - Lbit : constant Uint := - Static_Integer (Last_Bit (CC)); + Fbit : constant Uint := Static_Integer (First_Bit (CC)); + Lbit : constant Uint := Static_Integer (Last_Bit (CC)); begin -- Case of component with last bit >= max machine scalar @@ -412,16 +420,16 @@ package body Sem_Ch13 is if Warn_On_Reverse_Bit_Order then Error_Msg_N ("multi-byte field specified with " - & " non-standard Bit_Order?", CC); + & " non-standard Bit_Order?V?", CC); if Bytes_Big_Endian then Error_Msg_N ("\bytes are not reversed " - & "(component is big-endian)?", CC); + & "(component is big-endian)?V?", CC); else Error_Msg_N ("\bytes are not reversed " - & "(component is little-endian)?", CC); + & "(component is little-endian)?V?", CC); end if; end if; @@ -623,33 +631,31 @@ package body Sem_Ch13 is for C in Start .. Stop loop declare Comp : constant Entity_Id := Comps (C); - CC : constant Node_Id := - Component_Clause (Comp); - LB : constant Uint := - Static_Integer (Last_Bit (CC)); + CC : constant Node_Id := Component_Clause (Comp); + + LB : constant Uint := Static_Integer (Last_Bit (CC)); NFB : constant Uint := MSS - Uint_1 - LB; NLB : constant Uint := NFB + Esize (Comp) - 1; - Pos : constant Uint := - Static_Integer (Position (CC)); + Pos : constant Uint := Static_Integer (Position (CC)); begin if Warn_On_Reverse_Bit_Order then Error_Msg_Uint_1 := MSS; Error_Msg_N ("info: reverse bit order in machine " & - "scalar of length^?", First_Bit (CC)); + "scalar of length^?V?", First_Bit (CC)); Error_Msg_Uint_1 := NFB; Error_Msg_Uint_2 := NLB; if Bytes_Big_Endian then Error_Msg_NE - ("?\info: big-endian range for " - & "component & is ^ .. ^", + ("\info: big-endian range for " + & "component & is ^ .. ^?V?", First_Bit (CC), Comp); else Error_Msg_NE - ("?\info: little-endian range " - & "for component & is ^ .. ^", + ("\info: little-endian range " + & "for component & is ^ .. ^?V?", First_Bit (CC), Comp); end if; end if; @@ -696,6 +702,29 @@ package body Sem_Ch13 is -- This routine analyzes an Aspect_Default_[Component_]Value denoted by -- the aspect specification node ASN. + procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id); + -- As discussed in the spec of Aspects (see Aspect_Delay declaration), + -- a derived type can inherit aspects from its parent which have been + -- specified at the time of the derivation using an aspect, as in: + -- + -- type A is range 1 .. 10 + -- with Size => Not_Defined_Yet; + -- .. + -- type B is new A; + -- .. + -- Not_Defined_Yet : constant := 64; + -- + -- In this example, the Size of A is considered to be specified prior + -- to the derivation, and thus inherited, even though the value is not + -- known at the time of derivation. To deal with this, we use two entity + -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A + -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in + -- the derived type (B here). If this flag is set when the derived type + -- is frozen, then this procedure is called to ensure proper inheritance + -- of all delayed aspects from the parent type. The derived type is E, + -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first + -- aspect specification node in the Rep_Item chain for the parent type. + procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); -- Given an aspect specification node ASN whose expression is an -- optional Boolean, this routines creates the corresponding pragma @@ -741,12 +770,187 @@ package body Sem_Ch13 is Set_Has_Default_Aspect (Base_Type (Ent)); if Is_Scalar_Type (Ent) then - Set_Default_Aspect_Value (Ent, Expr); + Set_Default_Aspect_Value (Base_Type (Ent), Expr); else - Set_Default_Aspect_Component_Value (Ent, Expr); + Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr); end if; end Analyze_Aspect_Default_Value; + --------------------------------- + -- Inherit_Delayed_Rep_Aspects -- + --------------------------------- + + procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is + P : constant Entity_Id := Entity (ASN); + -- Entithy for parent type + + N : Node_Id; + -- Item from Rep_Item chain + + A : Aspect_Id; + + begin + -- Loop through delayed aspects for the parent type + + N := ASN; + while Present (N) loop + if Nkind (N) = N_Aspect_Specification then + exit when Entity (N) /= P; + + if Is_Delayed_Aspect (N) then + A := Get_Aspect_Id (Chars (Identifier (N))); + + -- Process delayed rep aspect. For Boolean attributes it is + -- not possible to cancel an attribute once set (the attempt + -- to use an aspect with xxx => False is an error) for a + -- derived type. So for those cases, we do not have to check + -- if a clause has been given for the derived type, since it + -- is harmless to set it again if it is already set. + + case A is + + -- Alignment + + when Aspect_Alignment => + if not Has_Alignment_Clause (E) then + Set_Alignment (E, Alignment (P)); + end if; + + -- Atomic + + when Aspect_Atomic => + if Is_Atomic (P) then + Set_Is_Atomic (E); + end if; + + -- Atomic_Components + + when Aspect_Atomic_Components => + if Has_Atomic_Components (P) then + Set_Has_Atomic_Components (Base_Type (E)); + end if; + + -- Bit_Order + + when Aspect_Bit_Order => + if Is_Record_Type (E) + and then No (Get_Attribute_Definition_Clause + (E, Attribute_Bit_Order)) + and then Reverse_Bit_Order (P) + then + Set_Reverse_Bit_Order (Base_Type (E)); + end if; + + -- Component_Size + + when Aspect_Component_Size => + if Is_Array_Type (E) + and then not Has_Component_Size_Clause (E) + then + Set_Component_Size + (Base_Type (E), Component_Size (P)); + end if; + + -- Machine_Radix + + when Aspect_Machine_Radix => + if Is_Decimal_Fixed_Point_Type (E) + and then not Has_Machine_Radix_Clause (E) + then + Set_Machine_Radix_10 (E, Machine_Radix_10 (P)); + end if; + + -- Object_Size (also Size which also sets Object_Size) + + when Aspect_Object_Size | Aspect_Size => + if not Has_Size_Clause (E) + and then + No (Get_Attribute_Definition_Clause + (E, Attribute_Object_Size)) + then + Set_Esize (E, Esize (P)); + end if; + + -- Pack + + when Aspect_Pack => + if not Is_Packed (E) then + Set_Is_Packed (Base_Type (E)); + + if Is_Bit_Packed_Array (P) then + Set_Is_Bit_Packed_Array (Base_Type (E)); + Set_Packed_Array_Type (E, Packed_Array_Type (P)); + end if; + end if; + + -- Scalar_Storage_Order + + when Aspect_Scalar_Storage_Order => + if (Is_Record_Type (E) or else Is_Array_Type (E)) + and then No (Get_Attribute_Definition_Clause + (E, Attribute_Scalar_Storage_Order)) + and then Reverse_Storage_Order (P) + then + Set_Reverse_Storage_Order (Base_Type (E)); + end if; + + -- Small + + when Aspect_Small => + if Is_Fixed_Point_Type (E) + and then not Has_Small_Clause (E) + then + Set_Small_Value (E, Small_Value (P)); + end if; + + -- Storage_Size + + when Aspect_Storage_Size => + if (Is_Access_Type (E) or else Is_Task_Type (E)) + and then not Has_Storage_Size_Clause (E) + then + Set_Storage_Size_Variable + (Base_Type (E), Storage_Size_Variable (P)); + end if; + + -- Value_Size + + when Aspect_Value_Size => + + -- Value_Size is never inherited, it is either set by + -- default, or it is explicitly set for the derived + -- type. So nothing to do here. + + null; + + -- Volatile + + when Aspect_Volatile => + if Is_Volatile (P) then + Set_Is_Volatile (E); + end if; + + -- Volatile_Components + + when Aspect_Volatile_Components => + if Has_Volatile_Components (P) then + Set_Has_Volatile_Components (Base_Type (E)); + end if; + + -- That should be all the Rep Aspects + + when others => + pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect); + null; + + end case; + end if; + end if; + + N := Next_Rep_Item (N); + end loop; + end Inherit_Delayed_Rep_Aspects; + ------------------------------------- -- Make_Pragma_From_Boolean_Aspect -- ------------------------------------- @@ -825,15 +1029,18 @@ package body Sem_Ch13 is -- Fall through means we are canceling an inherited aspect Error_Msg_Name_1 := A_Name; - Error_Msg_NE ("derived type& inherits aspect%, cannot cancel", - Expr, - E); + Error_Msg_NE + ("derived type& inherits aspect%, cannot cancel", Expr, E); end Check_False_Aspect_For_Derived_Type; -- Start of processing for Make_Pragma_From_Boolean_Aspect begin + -- Note that we know Expr is present, because for a missing Expr + -- argument, we knew it was True and did not need to delay the + -- evaluation to the freeze point. + if Is_False (Static_Boolean (Expr)) then Check_False_Aspect_For_Derived_Type; @@ -841,7 +1048,9 @@ package body Sem_Ch13 is Prag := Make_Pragma (Loc, Pragma_Argument_Associations => New_List ( - New_Occurrence_Of (Ent, Sloc (Ident))), + Make_Pragma_Argument_Association (Sloc (Ident), + Expression => New_Occurrence_Of (Ent, Sloc (Ident)))), + Pragma_Identifier => Make_Identifier (Sloc (Ident), Chars (Ident))); @@ -866,41 +1075,60 @@ package body Sem_Ch13 is ASN := First_Rep_Item (E); while Present (ASN) loop - if Nkind (ASN) = N_Aspect_Specification - and then Entity (ASN) = E - and then Is_Delayed_Aspect (ASN) - then - A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); + if Nkind (ASN) = N_Aspect_Specification then + exit when Entity (ASN) /= E; - case A_Id is + if Is_Delayed_Aspect (ASN) then + A_Id := Get_Aspect_Id (ASN); + + case A_Id is - -- For aspects whose expression is an optional Boolean, make - -- the corresponding pragma at the freezing point. + -- For aspects whose expression is an optional Boolean, make + -- the corresponding pragma at the freezing point. when Boolean_Aspects | Library_Unit_Aspects => Make_Pragma_From_Boolean_Aspect (ASN); - -- Special handling for aspects that don't correspond to - -- pragmas/attributes. + -- Special handling for aspects that don't correspond to + -- pragmas/attributes. when Aspect_Default_Value | Aspect_Default_Component_Value => Analyze_Aspect_Default_Value (ASN); + -- Ditto for iterator aspects, because the corresponding + -- attributes may not have been analyzed yet. + + when Aspect_Constant_Indexing | + Aspect_Variable_Indexing | + Aspect_Default_Iterator | + Aspect_Iterator_Element => + Analyze (Expression (ASN)); + when others => null; - end case; + end case; - Ritem := Aspect_Rep_Item (ASN); + Ritem := Aspect_Rep_Item (ASN); - if Present (Ritem) then - Analyze (Ritem); + if Present (Ritem) then + Analyze (Ritem); + end if; end if; end if; Next_Rep_Item (ASN); end loop; + + -- This is where we inherit delayed rep aspects from our parent. Note + -- that if we fell out of the above loop with ASN non-empty, it means + -- we hit an aspect for an entity other than E, and it must be the + -- type from which we were derived. + + if May_Inherit_Delayed_Rep_Aspects (E) then + Inherit_Delayed_Rep_Aspects (ASN); + end if; end Analyze_Aspects_At_Freeze_Point; ----------------------------------- @@ -908,6 +1136,100 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is + procedure Decorate_Delayed_Aspect_And_Pragma + (Asp : Node_Id; + Prag : Node_Id); + -- Establish the linkages between a delayed aspect and its corresponding + -- pragma. Set all delay-related flags on both constructs. + + procedure Insert_Delayed_Pragma (Prag : Node_Id); + -- Insert a postcondition-like pragma into the tree depending on the + -- context. Prag must denote one of the following: Pre, Post, Depends, + -- Global or Contract_Cases. + + ---------------------------------------- + -- Decorate_Delayed_Aspect_And_Pragma -- + ---------------------------------------- + + procedure Decorate_Delayed_Aspect_And_Pragma + (Asp : Node_Id; + Prag : Node_Id) + is + begin + Set_Aspect_Rep_Item (Asp, Prag); + Set_Corresponding_Aspect (Prag, Asp); + Set_From_Aspect_Specification (Prag); + Set_Is_Delayed_Aspect (Prag); + Set_Is_Delayed_Aspect (Asp); + Set_Parent (Prag, Asp); + end Decorate_Delayed_Aspect_And_Pragma; + + --------------------------- + -- Insert_Delayed_Pragma -- + --------------------------- + + procedure Insert_Delayed_Pragma (Prag : Node_Id) is + Aux : Node_Id; + + begin + -- When the context is a library unit, the pragma is added to the + -- Pragmas_After list. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Aux := Aux_Decls_Node (Parent (N)); + + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, New_List); + end if; + + Prepend (Prag, Pragmas_After (Aux)); + + -- Pragmas associated with subprogram bodies are inserted in the + -- declarative part. + + elsif Nkind (N) = N_Subprogram_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List (Prag)); + else + declare + D : Node_Id; + begin + + -- There may be several aspects associated with the body; + -- preserve the ordering of the corresponding pragmas. + + D := First (Declarations (N)); + while Present (D) loop + exit when Nkind (D) /= N_Pragma + or else not From_Aspect_Specification (D); + Next (D); + end loop; + + if No (D) then + Append (Prag, Declarations (N)); + else + Insert_Before (D, Prag); + end if; + end; + end if; + + -- Default + + else + Insert_After (N, Prag); + + -- Analyze the pragma before analyzing the proper body of a stub. + -- This ensures that the pragma will appear on the proper contract + -- list (see N_Contract). + + if Nkind (N) = N_Subprogram_Body_Stub then + Analyze (Prag); + end if; + end if; + end Insert_Delayed_Pragma; + + -- Local variables + Aspect : Node_Id; Aitem : Node_Id; Ent : Node_Id; @@ -918,6 +1240,8 @@ package body Sem_Ch13 is -- Insert pragmas/attribute definition clause after this node when no -- delayed analysis is required. + -- Start of processing for Analyze_Aspect_Specifications + -- The general processing involves building an attribute definition -- clause or a pragma node that corresponds to the aspect. Then in order -- to delay the evaluation of this aspect to the freeze point, we attach @@ -931,11 +1255,11 @@ package body Sem_Ch13 is -- Some special cases don't require delay analysis, thus the aspect is -- analyzed right now. - -- Note that there is a special handling for - -- Pre/Post/Test_Case/Contract_Case aspects. In this case, we do not - -- have to worry about delay issues, since the pragmas themselves deal - -- with delay of visibility for the expression analysis. Thus, we just - -- insert the pragma after the node N. + -- Note that there is a special handling for Pre, Post, Test_Case, + -- Contract_Cases aspects. In these cases, we do not have to worry + -- about delay issues, since the pragmas themselves deal with delay + -- of visibility for the expression analysis. Thus, we just insert + -- the pragma after the node N. begin pragma Assert (Present (L)); @@ -944,7 +1268,7 @@ package body Sem_Ch13 is Aspect := First (L); Aspect_Loop : while Present (Aspect) loop - declare + Analyze_One_Aspect : declare Expr : constant Node_Id := Expression (Aspect); Id : constant Node_Id := Identifier (Aspect); Loc : constant Source_Ptr := Sloc (Aspect); @@ -952,7 +1276,7 @@ package body Sem_Ch13 is A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); Anod : Node_Id; - Delay_Required : Boolean := True; + Delay_Required : Boolean; -- Set False if delay is not required Eloc : Source_Ptr := No_Location; @@ -960,12 +1284,22 @@ package body Sem_Ch13 is -- is set below when Expr is present. procedure Analyze_Aspect_External_Or_Link_Name; - -- This routine performs the analysis of the External_Name or - -- Link_Name aspects. + -- Perform analysis of the External_Name or Link_Name aspects procedure Analyze_Aspect_Implicit_Dereference; - -- This routine performs the analysis of the Implicit_Dereference - -- aspects. + -- Perform analysis of the Implicit_Dereference aspects + + procedure Make_Aitem_Pragma + (Pragma_Argument_Associations : List_Id; + Pragma_Name : Name_Id); + -- This is a wrapper for Make_Pragma used for converting aspects + -- to pragmas. It takes care of Sloc (set from Loc) and building + -- the pragma identifier from the given name. In addition the + -- flags Class_Present and Split_PPC are set from the aspect + -- node, as well as Is_Ignored. This routine also sets the + -- From_Aspect_Specification in the resulting pragma node to + -- True, and sets Corresponding_Aspect to point to the aspect. + -- The resulting pragma is assigned to Aitem. ------------------------------------------ -- Analyze_Aspect_External_Or_Link_Name -- @@ -984,14 +1318,14 @@ package body Sem_Ch13 is begin A := First (L); while Present (A) loop - exit when Chars (Identifier (A)) = Name_Export - or else Chars (Identifier (A)) = Name_Import; + exit when Nam_In (Chars (Identifier (A)), Name_Export, + Name_Import); Next (A); end loop; if No (A) then Error_Msg_N - ("Missing Import/Export for Link/External name", + ("missing Import/Export for Link/External name", Aspect); end if; end; @@ -1003,11 +1337,9 @@ package body Sem_Ch13 is procedure Analyze_Aspect_Implicit_Dereference is begin - if not Is_Type (E) - or else not Has_Discriminants (E) - then + if not Is_Type (E) or else not Has_Discriminants (E) then Error_Msg_N - ("Aspect must apply to a type with discriminants", N); + ("aspect must apply to a type with discriminants", N); else declare @@ -1036,6 +1368,52 @@ package body Sem_Ch13 is end if; end Analyze_Aspect_Implicit_Dereference; + ----------------------- + -- Make_Aitem_Pragma -- + ----------------------- + + procedure Make_Aitem_Pragma + (Pragma_Argument_Associations : List_Id; + Pragma_Name : Name_Id) + is + Args : List_Id := Pragma_Argument_Associations; + + begin + -- We should never get here if aspect was disabled + + pragma Assert (not Is_Disabled (Aspect)); + + -- Certain aspects allow for an optional name or expression. Do + -- not generate a pragma with empty argument association list. + + if No (Args) or else No (Expression (First (Args))) then + Args := No_List; + end if; + + -- Build the pragma + + Aitem := + Make_Pragma (Loc, + Pragma_Argument_Associations => Args, + Pragma_Identifier => + Make_Identifier (Sloc (Id), Pragma_Name), + Class_Present => Class_Present (Aspect), + Split_PPC => Split_PPC (Aspect)); + + -- Set additional semantic fields + + if Is_Ignored (Aspect) then + Set_Is_Ignored (Aitem); + elsif Is_Checked (Aspect) then + Set_Is_Checked (Aitem); + end if; + + Set_Corresponding_Aspect (Aitem, Aspect); + Set_From_Aspect_Specification (Aitem, True); + end Make_Aitem_Pragma; + + -- Start of processing for Analyze_One_Aspect + begin -- Skip aspect if already analyzed (not clear if this is needed) @@ -1043,6 +1421,16 @@ package body Sem_Ch13 is goto Continue; end if; + -- Skip looking at aspect if it is totally disabled. Just mark it + -- as such for later reference in the tree. This also sets the + -- Is_Ignored and Is_Checked flags appropriately. + + Check_Applicable_Policy (Aspect); + + if Is_Disabled (Aspect) then + 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 @@ -1057,7 +1445,7 @@ package body Sem_Ch13 is -- Check restriction No_Implementation_Aspect_Specifications - if Impl_Defined_Aspects (A_Id) then + if Implementation_Defined_Aspect (A_Id) then Check_Restriction (No_Implementation_Aspect_Specifications, Aspect); end if; @@ -1066,7 +1454,7 @@ package body Sem_Ch13 is Check_Restriction_No_Specification_Of_Aspect (Aspect); - -- Analyze this aspect + -- Analyze this aspect (actual analysis is delayed till later) Set_Analyzed (Aspect); Set_Entity (Aspect, E); @@ -1079,9 +1467,8 @@ package body Sem_Ch13 is 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) + if Comes_From_Source (Aspect) + and then Same_Aspect (A_Id, Get_Aspect_Id (Anod)) then Error_Msg_Name_1 := Nam; Error_Msg_Sloc := Sloc (Anod); @@ -1107,7 +1494,7 @@ package body Sem_Ch13 is -- Check some general restrictions on language defined aspects - if not Impl_Defined_Aspects (A_Id) then + if not Implementation_Defined_Aspect (A_Id) then Error_Msg_Name_1 := Nam; -- Not allowed for renaming declarations @@ -1132,6 +1519,31 @@ package body Sem_Ch13 is Set_Entity (Id, New_Copy_Tree (Expr)); + -- Set Delay_Required as appropriate to aspect + + case Aspect_Delay (A_Id) is + when Always_Delay => + Delay_Required := True; + + when Never_Delay => + Delay_Required := False; + + when Rep_Aspect => + + -- If expression has the form of an integer literal, then + -- do not delay, since we know the value cannot change. + -- This optimization catches most rep clause cases. + + if (Present (Expr) and then Nkind (Expr) = N_Integer_Literal) + or else (A_Id in Boolean_Aspects and then No (Expr)) + then + Delay_Required := False; + else + Delay_Required := True; + Set_Has_Delayed_Rep_Aspects (E); + end if; + end case; + -- Processing based on specific aspect case A_Id is @@ -1163,7 +1575,6 @@ package body Sem_Ch13 is Aspect_Small | Aspect_Simple_Storage_Pool | Aspect_Storage_Pool | - Aspect_Storage_Size | Aspect_Stream_Size | Aspect_Value_Size | Aspect_Variable_Indexing | @@ -1172,7 +1583,8 @@ package body Sem_Ch13 is -- Indexing aspects apply only to tagged type if (A_Id = Aspect_Constant_Indexing - or else A_Id = Aspect_Variable_Indexing) + or else + A_Id = Aspect_Variable_Indexing) and then not (Is_Type (E) and then Is_Tagged_Type (E)) then @@ -1180,6 +1592,18 @@ package body Sem_Ch13 is goto Continue; end if; + -- For case of address aspect, we don't consider that we + -- know the entity is never set in the source, since it is + -- is likely aliasing is occurring. + + -- Note: one might think that the analysis of the resulting + -- attribute definition clause would take care of that, but + -- that's not the case since it won't be from source. + + if A_Id = Aspect_Address then + Set_Never_Set_In_Source (E, False); + end if; + -- Construct the attribute definition clause Aitem := @@ -1188,78 +1612,104 @@ package body Sem_Ch13 is Chars => Chars (Id), Expression => Relocate_Node (Expr)); - -- Case 2: Aspects cooresponding to pragmas + -- If the address is specified, then we treat the entity as + -- referenced, to avoid spurious warnings. This is analogous + -- to what is done with an attribute definition clause, but + -- here we don't want to generate a reference because this + -- is the point of definition of the entity. + + if A_Id = Aspect_Address then + Set_Referenced (E); + end if; + + -- Case 2: Aspects corresponding to pragmas -- Case 2a: Aspects corresponding to pragmas with two -- arguments, where the first argument is a local name -- referring to the entity, and the second argument is the -- aspect definition expression. + -- Suppress/Unsuppress + when Aspect_Suppress | Aspect_Unsuppress => - -- Construct the pragma + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Chars (Id)); - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - New_Occurrence_Of (E, Loc), - Relocate_Node (Expr)), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); - - when Aspect_Synchronization => + -- Synchronization - -- The aspect corresponds to pragma Implemented. - -- Construct the pragma + -- 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)); + when Aspect_Synchronization => - -- No delay is required since the only values are: By_Entry - -- | By_Protected_Procedure | By_Any | Optional which don't - -- get analyzed anyway. + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Implemented); - Delay_Required := False; + -- Attach Handler 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))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Attach_Handler); + + -- Dynamic_Predicate, Predicate, Static_Predicate when Aspect_Dynamic_Predicate | Aspect_Predicate | Aspect_Static_Predicate => -- Construct the pragma (always a pragma Predicate, with - -- flags recording whether it is static/dynamic). + -- flags recording whether it is static/dynamic). We also + -- set flags recording this in the type itself. - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => - New_List (Ent, Relocate_Node (Expr)), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Predicate)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Predicate); + + -- Mark type has predicates, and remember what kind of + -- aspect lead to this predicate (we need this to access + -- the right set of check policies later on). + + Set_Has_Predicates (E); + + if A_Id = Aspect_Dynamic_Predicate then + Set_Has_Dynamic_Predicate_Aspect (E); + elsif A_Id = Aspect_Static_Predicate then + Set_Has_Static_Predicate_Aspect (E); + end if; -- 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 + if Is_Private_Type (E) and then Present (Full_View (E)) then Set_Has_Predicates (Full_View (E)); + + if A_Id = Aspect_Dynamic_Predicate then + Set_Has_Dynamic_Predicate_Aspect (Full_View (E)); + elsif A_Id = Aspect_Static_Predicate then + Set_Has_Static_Predicate_Aspect (Full_View (E)); + end if; + Set_Has_Delayed_Aspects (Full_View (E)); Ensure_Freeze_Node (Full_View (E)); end if; @@ -1269,6 +1719,8 @@ package body Sem_Ch13 is -- referring to the entity, and the first argument is the -- aspect definition expression. + -- Convention + when Aspect_Convention => -- The aspect may be part of the specification of an import @@ -1296,9 +1748,7 @@ package body Sem_Ch13 is while Present (A) loop A_Name := Chars (Identifier (A)); - if A_Name = Name_Import - or else A_Name = Name_Export - then + if Nam_In (A_Name, Name_Import, Name_Export) then if Found then Error_Msg_N ("conflicting", A); else @@ -1308,20 +1758,27 @@ package body Sem_Ch13 is P_Name := A_Name; elsif A_Name = Name_Link_Name then - L_Assoc := Make_Pragma_Argument_Association (Loc, - Chars => A_Name, - Expression => Relocate_Node (Expression (A))); + L_Assoc := + Make_Pragma_Argument_Association (Loc, + Chars => A_Name, + Expression => Relocate_Node (Expression (A))); elsif A_Name = Name_External_Name then - E_Assoc := Make_Pragma_Argument_Association (Loc, - Chars => A_Name, - Expression => Relocate_Node (Expression (A))); + E_Assoc := + Make_Pragma_Argument_Association (Loc, + Chars => A_Name, + Expression => Relocate_Node (Expression (A))); end if; Next (A); end loop; - Arg_List := New_List (Relocate_Node (Expr), Ent); + Arg_List := New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr)), + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)); + if Present (L_Assoc) then Append_To (Arg_List, L_Assoc); end if; @@ -1330,29 +1787,133 @@ package body Sem_Ch13 is Append_To (Arg_List, E_Assoc); end if; - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => Arg_List, - Pragma_Identifier => - Make_Identifier (Loc, P_Name)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => Arg_List, + Pragma_Name => P_Name); end; - -- The following three aspects can be specified for a - -- subprogram body, in which case we generate pragmas for them - -- and insert them ahead of local declarations, rather than - -- after the body. + -- CPU, Interrupt_Priority, Priority + + -- These three aspects can be specified for a subprogram spec + -- or body, in which case we analyze the expression and export + -- the value of the aspect. + + -- Previously, we generated an equivalent pragma for bodies + -- (note that the specs cannot contain these pragmas). The + -- pragma was inserted ahead of local declarations, rather than + -- after the body. This leads to a certain duplication between + -- the processing performed for the aspect and the pragma, but + -- given the straightforward handling required it is simpler + -- to duplicate than to translate the aspect in the spec into + -- a pragma in the declarative part of the body. when Aspect_CPU | Aspect_Interrupt_Priority | Aspect_Priority => - if Nkind (N) = N_Subprogram_Body then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => - New_List (Relocate_Node (Expr)), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + + if Nkind_In (N, N_Subprogram_Body, + N_Subprogram_Declaration) + then + -- Analyze the aspect expression + + Analyze_And_Resolve (Expr, Standard_Integer); + + -- Interrupt_Priority aspect not allowed for main + -- subprograms. ARM D.1 does not forbid this explicitly, + -- but ARM J.15.11 (6/3) does not permit pragma + -- Interrupt_Priority for subprograms. + + if A_Id = Aspect_Interrupt_Priority then + Error_Msg_N + ("Interrupt_Priority aspect cannot apply to " + & "subprogram", Expr); + + -- The expression must be static + + elsif not Is_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("aspect requires static expression!", Expr); + + -- Check whether this is the main subprogram. Issue a + -- warning only if it is obviously not a main program + -- (when it has parameters or when the subprogram is + -- within a package). + + elsif Present (Parameter_Specifications + (Specification (N))) + or else not Is_Compilation_Unit (Defining_Entity (N)) + then + -- See ARM D.1 (14/3) and D.16 (12/3) + + Error_Msg_N + ("aspect applied to subprogram other than the " + & "main subprogram has no effect??", Expr); + + -- Otherwise check in range and export the value + + -- For the CPU aspect + + elsif A_Id = Aspect_CPU then + if Is_In_Range (Expr, RTE (RE_CPU_Range)) then + + -- Value is correct so we export the value to make + -- it available at execution time. + + Set_Main_CPU + (Main_Unit, UI_To_Int (Expr_Value (Expr))); + + else + Error_Msg_N + ("main subprogram CPU is out of range", Expr); + end if; + + -- For the Priority aspect + + elsif A_Id = Aspect_Priority then + if Is_In_Range (Expr, RTE (RE_Priority)) then + + -- Value is correct so we export the value to make + -- it available at execution time. + + Set_Main_Priority + (Main_Unit, UI_To_Int (Expr_Value (Expr))); + + else + Error_Msg_N + ("main subprogram priority is out of range", + Expr); + end if; + end if; + + -- Load an arbitrary entity from System.Tasking.Stages + -- or System.Tasking.Restricted.Stages (depending on + -- the supported profile) to make sure that one of these + -- packages is implicitly with'ed, since we need to have + -- the tasking run time active for the pragma Priority to + -- have any effect. Previously with with'ed the package + -- System.Tasking, but this package does not trigger the + -- required initialization of the run-time library. + + declare + Discard : Entity_Id; + pragma Warnings (Off, Discard); + begin + if Restricted_Profile then + Discard := RTE (RE_Activate_Restricted_Tasks); + else + Discard := RTE (RE_Activate_Tasks); + end if; + end; + + -- Handling for these Aspects in subprograms is complete + + goto Continue; + + -- For tasks + else + -- Pass the aspect as an attribute + Aitem := Make_Attribute_Definition_Clause (Loc, Name => Ent, @@ -1360,23 +1921,16 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr)); end if; - when Aspect_Warnings => - - -- Construct the pragma + -- Warnings - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List ( - Relocate_Node (Expr), - New_Occurrence_Of (E, Loc)), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id)), - Class_Present => Class_Present (Aspect)); - - -- 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; + when Aspect_Warnings => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr)), + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc))), + Pragma_Name => Chars (Id)); -- Case 2c: Aspects corresponding to pragmas with three -- arguments. @@ -1385,6 +1939,8 @@ package body Sem_Ch13 is -- entity, a second argument that is the expression and a third -- argument that is an appropriate message. + -- Invariant, Type_Invariant + when Aspect_Invariant | Aspect_Type_Invariant => @@ -1392,15 +1948,13 @@ package body Sem_Ch13 is -- 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 := - Make_Pragma (Loc, - Pragma_Argument_Associations => - New_List (Ent, Relocate_Node (Expr)), - Class_Present => Class_Present (Aspect), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Name_Invariant)); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Invariant); -- Add message unless exception messages are suppressed @@ -1420,12 +1974,298 @@ package body Sem_Ch13 is Delay_Required := False; + -- Case 2d : Aspects that correspond to a pragma with one + -- argument. + + -- Abstract_State + + -- Aspect Abstract_State introduces implicit declarations for + -- all state abstraction entities it defines. To emulate this + -- behavior, insert the pragma at the beginning of the visible + -- declarations of the related package so that it is analyzed + -- immediately. + + when Aspect_Abstract_State => Abstract_State : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Abstract_State); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Abstract_State; + + -- Depends + + -- Aspect Depends must be delayed because it mentions names + -- of inputs and output that are classified by aspect Global. + -- The aspect and pragma are treated the same way as a post + -- condition. + + when Aspect_Depends => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Depends); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Global + + -- Aspect Global must be delayed because it can mention names + -- and benefit from the forward visibility rules applicable to + -- aspects of subprograms. The aspect and pragma are treated + -- the same way as a post condition. + + when Aspect_Global => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Global); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Initial_Condition + + -- Aspect Initial_Condition covers the visible declarations of + -- a package and all hidden states through functions. As such, + -- it must be evaluated at the end of the said declarations. + + when Aspect_Initial_Condition => Initial_Condition : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => + Name_Initial_Condition); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Initial_Condition; + + -- Initializes + + -- Aspect Initializes coverts the visible declarations of a + -- package. As such, it must be evaluated at the end of the + -- said declarations. + + when Aspect_Initializes => Initializes : declare + Decls : List_Id; + + begin + if Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decls := Visible_Declarations (Specification (N)); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Initializes); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Visible_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package declaration", + Aspect, Id); + end if; + + goto Continue; + end Initializes; + + -- SPARK_Mode + + when Aspect_SPARK_Mode => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_SPARK_Mode); + + -- Refined_Depends + + -- Aspect Refined_Depends must be delayed because it can + -- mention state refinements introduced by aspect Refined_State + -- and further classified by aspect Refined_Global. Since both + -- those aspects are delayed, so is Refined_Depends. + + when Aspect_Refined_Depends => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Depends); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Refined_Global + + -- Aspect Refined_Global must be delayed because it can mention + -- state refinements introduced by aspect Refined_State. Since + -- Refined_State is already delayed due to forward references, + -- so is Refined_Global. + + when Aspect_Refined_Global => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Global); + + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; + + -- Refined_Post + + when Aspect_Refined_Post => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_Post); + + -- Refined_State + + when Aspect_Refined_State => Refined_State : declare + Decls : List_Id; + + begin + -- The corresponding pragma for Refined_State is inserted in + -- the declarations of the related package body. This action + -- synchronizes both the source and from-aspect versions of + -- the pragma. + + if Nkind (N) = N_Package_Body then + Decls := Declarations (N); + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Refined_State); + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; + + Prepend_To (Decls, Aitem); + + else + Error_Msg_NE + ("aspect & must apply to a package body", Aspect, Id); + end if; + + goto Continue; + end Refined_State; + + -- Relative_Deadline + + when Aspect_Relative_Deadline => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Relative_Deadline); + + -- If the aspect applies to a task, the corresponding pragma + -- must appear within its declarations, not after. + + if Nkind (N) = N_Task_Type_Declaration then + declare + Def : Node_Id; + V : List_Id; + + begin + if No (Task_Definition (N)) then + Set_Task_Definition (N, + Make_Task_Definition (Loc, + Visible_Declarations => New_List, + End_Label => Empty)); + end if; + + Def := Task_Definition (N); + V := Visible_Declarations (Def); + if not Is_Empty_List (V) then + Insert_Before (First (V), Aitem); + + else + Set_Visible_Declarations (Def, New_List (Aitem)); + end if; + + goto Continue; + end; + end if; + -- Case 3 : Aspects that don't correspond to pragma/attribute -- definition clause. -- Case 3a: The aspects listed below don't correspond to -- pragmas/attributes but do require delayed analysis. + -- Default_Value, Default_Component_Value + when Aspect_Default_Value | Aspect_Default_Component_Value => Aitem := Empty; @@ -1433,6 +2273,8 @@ package body Sem_Ch13 is -- Case 3b: The aspects listed below don't correspond to -- pragmas/attributes and don't need delayed analysis. + -- Implicit_Dereference + -- For Implicit_Dereference, External_Name and Link_Name, only -- the legality checks are done during the analysis, thus no -- delay is required. @@ -1441,22 +2283,31 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; + -- External_Name, Link_Name + when Aspect_External_Name | Aspect_Link_Name => Analyze_Aspect_External_Or_Link_Name; goto Continue; + -- Dimension + when Aspect_Dimension => Analyze_Aspect_Dimension (N, Id, Expr); goto Continue; + -- Dimension_System + when Aspect_Dimension_System => Analyze_Aspect_Dimension_System (N, Id, Expr); goto Continue; - -- Case 4: Special handling for aspects - -- Pre/Post/Test_Case/Contract_Case whose corresponding pragmas - -- take care of the delay. + -- Case 4: Aspects requiring special handling + + -- Pre/Post/Test_Case/Contract_Cases whose corresponding + -- pragmas take care of the delay. + + -- Pre/Post -- Aspects Pre/Post generate Precondition/Postcondition pragmas -- with a first argument that is the expression, and a second @@ -1465,7 +2316,7 @@ package body Sem_Ch13 is -- required pragma placement. The processing for the pragmas -- takes care of the required delay. - when Pre_Post_Aspects => declare + when Pre_Post_Aspects => Pre_Post : declare Pname : Name_Id; begin @@ -1511,16 +2362,14 @@ package body Sem_Ch13 is -- Build the precondition/postcondition pragma - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Pname), - Class_Present => Class_Present (Aspect), - Split_PPC => Split_PPC (Aspect), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Eloc, - Chars => Name_Check, - Expression => Relocate_Node (Expr)))); + -- Add note about why we do NOT need Copy_Tree here ??? + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Eloc, + Chars => Name_Check, + Expression => Relocate_Node (Expr))), + Pragma_Name => Pname); -- Add message unless exception messages are suppressed @@ -1536,8 +2385,6 @@ package body Sem_Ch13 is & Build_Location_String (Eloc)))); 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 @@ -1546,98 +2393,96 @@ package body Sem_Ch13 is -- about delay issues, since the pragmas themselves deal -- with delay of visibility for the expression analysis. - -- If the entity is a library-level subprogram, the pre/ - -- postconditions must be treated as late pragmas. + Insert_Delayed_Pragma (Aitem); + goto Continue; + end Pre_Post; - if Nkind (Parent (N)) = N_Compilation_Unit then - Add_Global_Declaration (Aitem); - else - Insert_After (N, Aitem); - end if; + -- Test_Case - goto Continue; - end; + when Aspect_Test_Case => Test_Case : declare + Args : List_Id; + Comp_Expr : Node_Id; + Comp_Assn : Node_Id; + New_Expr : Node_Id; - when Aspect_Contract_Case | - Aspect_Test_Case => - declare - Args : List_Id; - Comp_Expr : Node_Id; - Comp_Assn : Node_Id; - New_Expr : Node_Id; + begin + Args := New_List; - begin - Args := New_List; + if Nkind (Parent (N)) = N_Compilation_Unit then + Error_Msg_Name_1 := Nam; + Error_Msg_N ("incorrect placement of aspect `%`", E); + goto Continue; + end if; - if Nkind (Parent (N)) = N_Compilation_Unit then - Error_Msg_Name_1 := Nam; - Error_Msg_N ("incorrect placement of aspect `%`", E); - goto Continue; - end if; + if Nkind (Expr) /= N_Aggregate then + Error_Msg_Name_1 := Nam; + Error_Msg_NE + ("wrong syntax for aspect `%` 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_To (Args, + Make_Pragma_Argument_Association (Sloc (Comp_Expr), + Expression => New_Expr)); + Next (Comp_Expr); + end loop; - if Nkind (Expr) /= N_Aggregate then + 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_Name_1 := Nam; Error_Msg_NE ("wrong syntax for aspect `%` 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; + New_Expr := Relocate_Node (Expression (Comp_Assn)); + Set_Original_Node (New_Expr, Expression (Comp_Assn)); + Append_To (Args, + Make_Pragma_Argument_Association (Sloc (Comp_Assn), + Chars => Chars (First (Choices (Comp_Assn))), + Expression => New_Expr)); + Next (Comp_Assn); + 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_Name_1 := Nam; - Error_Msg_NE - ("wrong syntax for aspect `%` for &", Id, E); - goto Continue; - end if; + -- Build the test-case pragma - 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; + Make_Aitem_Pragma + (Pragma_Argument_Associations => Args, + Pragma_Name => Nam); + end Test_Case; - -- Build the contract-case or test-case pragma + -- Contract_Cases - Aitem := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Sloc (Id), Nam), - Pragma_Argument_Associations => - Args); + when Aspect_Contract_Cases => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Nam); - Delay_Required := False; - end; + Decorate_Delayed_Aspect_And_Pragma (Aspect, Aitem); + Insert_Delayed_Pragma (Aitem); + goto Continue; -- Case 5: Special handling for aspects with an optional -- boolean argument. -- In the general case, the corresponding pragma cannot be - -- generated yet because the evaluation of the boolean needs to - -- be delayed til the freeze point. + -- generated yet because the evaluation of the boolean needs + -- to be delayed till the freeze point. when Boolean_Aspects | Library_Unit_Aspects => @@ -1655,9 +2500,9 @@ package body Sem_Ch13 is else -- Set the Uses_Lock_Free flag to True if there is no - -- expression or if the expression is True. ??? The + -- expression or if the expression is True. The -- evaluation of this aspect should be delayed to the - -- freeze point. + -- freeze point (why???) if No (Expr) or else Is_True (Static_Boolean (Expr)) @@ -1686,23 +2531,49 @@ package body Sem_Ch13 is Next (A); end loop; + -- It is legal to specify Import for a variable, in + -- order to suppress initialization for it, without + -- specifying explicitly its convention. However this + -- is only legal if the convention of the object type + -- is Ada or similar. + if No (A) then + if Ekind (E) = E_Variable + and then A_Id = Aspect_Import + then + declare + C : constant Convention_Id := + Convention (Etype (E)); + begin + if C = Convention_Ada or else + C = Convention_Ada_Pass_By_Copy or else + C = Convention_Ada_Pass_By_Reference + then + goto Continue; + end if; + end; + end if; + + -- Otherwise, Convention must be specified + Error_Msg_N ("missing Convention aspect for Export/Import", - Aspect); + Aspect); end if; end; goto Continue; end if; - -- This requires special handling in the case of a package - -- declaration, the pragma needs to be inserted in the list - -- of declarations for the associated package. There is no - -- issue of visibility delay for these aspects. + -- Library unit aspects require special handling in the case + -- of a package declaration, the pragma needs to be inserted + -- in the list of declarations for the associated package. + -- There is no issue of visibility delay for these aspects. if A_Id in Library_Unit_Aspects - and then Nkind (N) = N_Package_Declaration + and then + Nkind_In (N, N_Package_Declaration, + N_Generic_Package_Declaration) and then Nkind (Parent (N)) /= N_Compilation_Unit then Error_Msg_N @@ -1710,26 +2581,80 @@ package body Sem_Ch13 is goto Continue; end if; - -- Special handling when the aspect has no expression. In - -- this case the value is considered to be True. Thus, we - -- simply insert the pragma, no delay is required. - - if No (Expr) then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List (Ent), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + -- Cases where we do not delay, includes all cases where + -- the expression is missing other than the above cases. + if not Delay_Required or else No (Expr) then + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)), + Pragma_Name => Chars (Id)); Delay_Required := False; -- In general cases, the corresponding pragma/attribute -- definition clause will be inserted later at the freezing - -- point. + -- point, and we do not need to build it now else Aitem := Empty; end if; + + -- Storage_Size + + -- This is special because for access types we need to generate + -- an attribute definition clause. This also works for single + -- task declarations, but it does not work for task type + -- declarations, because we have the case where the expression + -- references a discriminant of the task type. That can't use + -- an attribute definition clause because we would not have + -- visibility on the discriminant. For that case we must + -- generate a pragma in the task definition. + + when Aspect_Storage_Size => + + -- Task type case + + if Ekind (E) = E_Task_Type then + declare + Decl : constant Node_Id := Declaration_Node (E); + + begin + pragma Assert (Nkind (Decl) = N_Task_Type_Declaration); + + -- If no task definition, create one + + if No (Task_Definition (Decl)) then + Set_Task_Definition (Decl, + Make_Task_Definition (Loc, + Visible_Declarations => Empty_List, + End_Label => Empty)); + end if; + + -- Create a pragma and put it at the start of the + -- task definition for the task type declaration. + + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Storage_Size); + + Prepend + (Aitem, + Visible_Declarations (Task_Definition (Decl))); + goto Continue; + end; + + -- All other cases, generate attribute definition + + else + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + end if; end case; -- Attach the corresponding pragma/attribute definition clause to @@ -1737,16 +2662,15 @@ package body Sem_Ch13 is if Present (Aitem) then Set_From_Aspect_Specification (Aitem, True); - - if Nkind (Aitem) = N_Pragma then - Set_Corresponding_Aspect (Aitem, Aspect); - end if; end if; -- In the context of a compilation unit, we directly put the - -- pragma in the Pragmas_After list of the - -- N_Compilation_Unit_Aux node (No delay is required here) - -- except for aspects on a subprogram body (see below). + -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux + -- node (no delay is required here) except for aspects on a + -- subprogram body (see below) and a generic package, for which + -- we need to introduce the pragma before building the generic + -- copy (see sem_ch12), and for package instantiations, where + -- the library unit pragmas are better handled early. if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) @@ -1760,15 +2684,13 @@ package body Sem_Ch13 is -- For a Boolean aspect, create the corresponding pragma if -- no expression or if the value is True. - if Is_Boolean_Aspect (Aspect) - and then No (Aitem) - then + if Is_Boolean_Aspect (Aspect) and then No (Aitem) then if Is_True (Static_Boolean (Expr)) then - Aitem := - Make_Pragma (Loc, - Pragma_Argument_Associations => New_List (Ent), - Pragma_Identifier => - Make_Identifier (Sloc (Id), Chars (Id))); + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)), + Pragma_Name => Chars (Id)); Set_From_Aspect_Specification (Aitem, True); Set_Corresponding_Aspect (Aitem, Aspect); @@ -1778,20 +2700,39 @@ package body Sem_Ch13 is end if; end if; - -- If the aspect is on a subprogram body (relevant aspects - -- are Inline and Priority), add the pragma in front of - -- the declarations. + -- If the aspect is on a subprogram body (relevant aspect + -- is Inline), add the pragma in front of the declarations. if Nkind (N) = N_Subprogram_Body then if No (Declarations (N)) then Set_Declarations (N, New_List); end if; - Prepend (Aitem, Declarations (N)); + Prepend (Aitem, Declarations (N)); + + elsif Nkind (N) = N_Generic_Package_Declaration then + if No (Visible_Declarations (Specification (N))) then + Set_Visible_Declarations (Specification (N), New_List); + end if; + + Prepend (Aitem, + Visible_Declarations (Specification (N))); + + elsif Nkind (N) = N_Package_Instantiation then + declare + Spec : constant Node_Id := + Specification (Instance_Spec (N)); + begin + if No (Visible_Declarations (Spec)) then + Set_Visible_Declarations (Spec, New_List); + end if; + + Prepend (Aitem, Visible_Declarations (Spec)); + end; else if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, Empty_List); + Set_Pragmas_After (Aux, New_List); end if; Append (Aitem, Pragmas_After (Aux)); @@ -1803,8 +2744,7 @@ package body Sem_Ch13 is -- The evaluation of the aspect is delayed to the freezing point. -- The pragma or attribute clause if there is one is then attached - -- to the aspect specification which is placed in the rep item - -- list. + -- to the aspect specification which is put in the rep item list. if Delay_Required then if Present (Aitem) then @@ -1814,9 +2754,37 @@ package body Sem_Ch13 is end if; Set_Is_Delayed_Aspect (Aspect); + + -- In the case of Default_Value, link the aspect to base type + -- as well, even though it appears on a first subtype. This is + -- mandated by the semantics of the aspect. Do not establish + -- the link when processing the base type itself as this leads + -- to a rep item circularity. Verify that we are dealing with + -- a scalar type to prevent cascaded errors. + + if A_Id = Aspect_Default_Value + and then Is_Scalar_Type (E) + and then Base_Type (E) /= E + then + Set_Has_Delayed_Aspects (Base_Type (E)); + Record_Rep_Item (Base_Type (E), Aspect); + end if; + Set_Has_Delayed_Aspects (E); Record_Rep_Item (E, Aspect); + -- When delay is not required and the context is a package or a + -- subprogram body, insert the pragma in the body declarations. + + elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + -- The pragma is added before source declarations + + Prepend_To (Declarations (N), Aitem); + -- When delay is not required and the context is not a compilation -- unit, we simply insert the pragma/attribute definition clause -- in sequence. @@ -1825,7 +2793,7 @@ package body Sem_Ch13 is Insert_After (Ins_Node, Aitem); Ins_Node := Aitem; end if; - end; + end Analyze_One_Aspect; <> Next (Aspect); @@ -1853,17 +2821,17 @@ package body Sem_Ch13 is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("at clause is an obsolescent feature (RM J.7(2))?", N); + ("?j?at clause is an obsolescent feature (RM J.7(2))", N); Error_Msg_N - ("\use address attribute definition clause instead?", N); + ("\?j?use address attribute definition clause instead", N); end if; -- Rewrite as address clause Rewrite (N, Make_Attribute_Definition_Clause (Sloc (N), - Name => Identifier (N), - Chars => Name_Address, + Name => Identifier (N), + Chars => Name_Address, Expression => Expression (N))); -- We preserve Comes_From_Source, since logically the clause still comes @@ -1919,7 +2887,7 @@ package body Sem_Ch13 is 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. + -- check that some interpretation is legal. procedure Check_Iterator_Functions; -- Check that there is a single function in Default_Iterator attribute @@ -2070,9 +3038,11 @@ package body Sem_Ch13 is ------------------------------ procedure Check_Indexing_Functions is + Indexing_Found : Boolean; procedure Check_One_Function (Subp : Entity_Id); - -- Check one possible interpretation + -- Check one possible interpretation. Sets Indexing_Found True if an + -- indexing function is found. ------------------------ -- Check_One_Function -- @@ -2080,34 +3050,44 @@ package body Sem_Ch13 is procedure Check_One_Function (Subp : Entity_Id) is Default_Element : constant Node_Id := - Find_Aspect + Find_Value_Of_Aspect (Etype (First_Formal (Subp)), Aspect_Iterator_Element); begin - if not Check_Primitive_Function (Subp) then + if not Check_Primitive_Function (Subp) + and then not Is_Overloaded (Expr) + then Error_Msg_NE ("aspect Indexing requires a function that applies to type&", - Subp, Ent); + Subp, Ent); end if; -- An indexing function must return either the default element of - -- the container, or a reference type. + -- the container, or a reference type. For variable indexing it + -- must be the latter. if Present (Default_Element) then Analyze (Default_Element); + if Is_Entity_Name (Default_Element) and then Covers (Entity (Default_Element), Etype (Subp)) then + Indexing_Found := True; return; end if; end if; - -- Otherwise the return type must be a reference type. + -- For variable_indexing the return type must be a reference type - if not Has_Implicit_Dereference (Etype (Subp)) then + if Attr = Name_Variable_Indexing + and then not Has_Implicit_Dereference (Etype (Subp)) + then Error_Msg_N ("function for indexing must return a reference type", Subp); + + else + Indexing_Found := True; end if; end Check_One_Function; @@ -2129,6 +3109,7 @@ package body Sem_Ch13 is It : Interp; begin + Indexing_Found := False; Get_First_Interp (Expr, I, It); while Present (It.Nam) loop @@ -2142,6 +3123,12 @@ package body Sem_Ch13 is Get_Next_Interp (I, It); end loop; + + if not Indexing_Found then + Error_Msg_NE + ("aspect Indexing requires a function that " + & "applies to type&", Expr, Ent); + end if; end; end if; end Check_Indexing_Functions; @@ -2495,6 +3482,7 @@ package body Sem_Ch13 is end if; Set_Entity (N, U_Ent); + Check_Restriction_No_Use_Of_Attribute (N); -- Switch on particular attribute @@ -2578,9 +3566,9 @@ package body Sem_Ch13 is and then Comes_From_Source (Scope (U_Ent)) then Error_Msg_N - ("?entry address declared for entry in task type", N); + ("??entry address declared for entry in task type", N); Error_Msg_N - ("\?only one task can be declared of this type", N); + ("\??only one task can be declared of this type", N); end if; -- Entry address clauses are obsolescent @@ -2589,10 +3577,10 @@ package body Sem_Ch13 is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("attaching interrupt to task entry is an " & - "obsolescent feature (RM J.7.1)?", N); + ("?j?attaching interrupt to task entry is an " & + "obsolescent feature (RM J.7.1)", N); Error_Msg_N - ("\use interrupt procedure instead?", N); + ("\?j?use interrupt procedure instead", N); end if; -- Case of an address clause for a controlled object which we @@ -2602,9 +3590,9 @@ package body Sem_Ch13 is or else Has_Controlled_Component (Etype (U_Ent)) then Error_Msg_NE - ("?controlled object& must not be overlaid", Nam, U_Ent); + ("??controlled object& must not be overlaid", Nam, U_Ent); Error_Msg_N - ("\?Program_Error will be raised at run time", Nam); + ("\??Program_Error will be raised at run time", Nam); Insert_Action (Declaration_Node (U_Ent), Make_Raise_Program_Error (Loc, Reason => PE_Overlaid_Controlled_Object)); @@ -2641,9 +3629,9 @@ package body Sem_Ch13 is or else Is_Controlled (Etype (O_Ent))) then Error_Msg_N - ("?cannot overlay with controlled object", Expr); + ("??cannot overlay with controlled object", Expr); Error_Msg_N - ("\?Program_Error will be raised at run time", Expr); + ("\??Program_Error will be raised at run time", Expr); Insert_Action (Declaration_Node (U_Ent), Make_Raise_Program_Error (Loc, Reason => PE_Overlaid_Controlled_Object)); @@ -2653,7 +3641,7 @@ package body Sem_Ch13 is and then Ekind (U_Ent) = E_Constant and then not Is_Constant_Object (O_Ent) then - Error_Msg_N ("constant overlays a variable?", Expr); + Error_Msg_N ("??constant overlays a variable", Expr); -- Imported variables can have an address clause, but then -- the import is pretty meaningless except to suppress @@ -2680,14 +3668,30 @@ package body Sem_Ch13 is if Present (O_Ent) and then Is_Object (O_Ent) and then not Off + + -- The following test is an expedient solution to what + -- is really a problem in CodePeer. Suppressing the + -- Set_Treat_As_Volatile call here prevents later + -- generation (in some cases) of trees that CodePeer + -- should, but currently does not, handle correctly. + -- This test should probably be removed when CodePeer + -- is improved, just because we want the tree CodePeer + -- analyzes to match the tree for which we generate code + -- as closely as is practical. ??? + + and then not CodePeer_Mode then + -- ??? O_Ent might not be in current unit + Set_Treat_As_Volatile (O_Ent); end if; -- Legality checks on the address clause for initialized -- objects is deferred until the freeze point, because -- a subsequent pragma might indicate that the object - -- is imported and thus not initialized. + -- is imported and thus not initialized. Also, the address + -- clause might involve entities that have yet to be + -- elaborated. Set_Has_Delayed_Freeze (U_Ent); @@ -2698,11 +3702,26 @@ package body Sem_Ch13 is -- before its definition. declare - Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N); + Init_Call : constant Node_Id := + Remove_Init_Call (U_Ent, N); + begin if Present (Init_Call) then - Remove (Init_Call); - Append_Freeze_Action (U_Ent, Init_Call); + + -- If the init call is an expression with actions with + -- null expression, just extract the actions. + + if Nkind (Init_Call) = N_Expression_With_Actions + and then + Nkind (Expression (Init_Call)) = N_Null_Statement + then + Append_Freeze_Actions (U_Ent, Actions (Init_Call)); + + -- General case: move Init_Call to freeze actions + + else + Append_Freeze_Action (U_Ent, Init_Call); + end if; end if; end; @@ -2711,9 +3730,8 @@ package body Sem_Ch13 is ("& cannot be exported if an address clause is given", Nam); Error_Msg_N - ("\define and export a variable " & - "that holds its address instead", - Nam); + ("\define and export a variable " + & "that holds its address instead", Nam); end if; -- Entity has delayed freeze, so we will generate an @@ -2743,16 +3761,21 @@ package body Sem_Ch13 is -- then we make an entry in the table for checking the size -- and alignment of the overlaying variable. We defer this -- check till after code generation to take full advantage - -- of the annotation done by the back end. This entry is - -- only made if the address clause comes from source. + -- of the annotation done by the back end. -- If the entity has a generic type, the check will be -- performed in the instance if the actual type justifies -- it, and we do not insert the clause in the table to -- prevent spurious warnings. + -- Note: we used to test Comes_From_Source and only give + -- this warning for source entities, but we have removed + -- this test. It really seems bogus to generate overlays + -- that would trigger this warning in generated code. + -- Furthermore, by removing the test, we handle the + -- aspect case properly. + if Address_Clause_Overlay_Warnings - and then Comes_From_Source (N) and then Present (O_Ent) and then Is_Object (O_Ent) then @@ -2810,7 +3833,7 @@ package body Sem_Ch13 is if Is_Tagged_Type (U_Ent) and then Align > Max_Align then Error_Msg_N - ("?alignment for & set to Maximum_Aligment", Nam); + ("alignment for & set to Maximum_Aligment??", Nam); Set_Alignment (U_Ent, Max_Align); -- All other cases @@ -2938,7 +3961,7 @@ package body Sem_Ch13 is if not GNAT_Mode then Error_Msg_N - ("?component size ignored in this configuration", N); + ("component size ignored in this configuration??", N); end if; end if; @@ -2949,8 +3972,7 @@ package body Sem_Ch13 is and then RM_Size (Ctyp) /= Csize then Error_Msg_NE - ("?component size overrides size clause for&", - N, Ctyp); + ("component size overrides size clause for&?S?", N, Ctyp); end if; Set_Has_Component_Size_Clause (Btype, True); @@ -3106,11 +4128,12 @@ package body Sem_Ch13 is if not Is_Library_Level_Entity (U_Ent) then Error_Msg_NE - ("?non-unique external tag supplied for &", N, U_Ent); + ("??non-unique external tag supplied for &", N, U_Ent); Error_Msg_N - ("?\same external tag applies to all subprogram calls", N); + ("\??same external tag applies to all " + & "subprogram calls", N); Error_Msg_N - ("?\corresponding internal tag cannot be obtained", N); + ("\??corresponding internal tag cannot be obtained", N); end if; end if; end External_Tag; @@ -3346,9 +4369,17 @@ package body Sem_Ch13 is Flag_Non_Static_Expr ("Scalar_Storage_Order requires static expression!", Expr); - else - if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then + elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then + + -- Here for the case of a non-default (i.e. non-confirming) + -- Scalar_Storage_Order attribute definition. + + if Support_Nondefault_SSO_On_Target then Set_Reverse_Storage_Order (Base_Type (U_Ent), True); + else + Error_Msg_N + ("non-default Scalar_Storage_Order " + & "not supported on target", Expr); end if; end if; end if; @@ -3391,7 +4422,7 @@ package body Sem_Ch13 is -- case this is useless. Error_Msg_N - ("?size clauses are ignored in this configuration", N); + ("size clauses are ignored in this configuration??", N); end if; if Is_Type (U_Ent) then @@ -3626,7 +4657,17 @@ package body Sem_Ch13 is Name => Expr); begin - Insert_Before (N, Rnode); + -- If the attribute definition clause comes from an aspect + -- clause, then insert the renaming before the associated + -- entity's declaration, since the attribute clause has + -- not yet been appended to the declaration list. + + if From_Aspect_Specification (N) then + Insert_Before (Parent (Entity (N)), Rnode); + else + Insert_Before (N, Rnode); + end if; + Analyze (Rnode); Set_Associated_Storage_Pool (U_Ent, Pool); end; @@ -3676,13 +4717,18 @@ package body Sem_Ch13 is 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 (RM J.9)?", N); - Error_Msg_N ("\use Storage_Size pragma instead?", N); + -- Check obsolescent (but never obsolescent if from aspect!) + + if not From_Aspect_Specification (N) then + Check_Restriction (No_Obsolescent_Features, N); + + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("?j?storage size clause for task is an " & + "obsolescent feature (RM J.9)", N); + Error_Msg_N ("\?j?use Storage_Size pragma instead", N); + end if; end if; FOnly := True; @@ -3967,6 +5013,14 @@ package body Sem_Ch13 is return; end if; + -- Ignore enumeration rep clauses by default in CodePeer mode, + -- unless -gnatd.I is specified, as a work around for potential false + -- positive messages. + + if CodePeer_Mode and not Debug_Flag_Dot_II then + return; + end if; + -- First some basic error checks Find_Type (Ident); @@ -4230,222 +5284,51 @@ package body Sem_Ch13 is end if; end if; - else - Set_RM_Size (Enumtype, Minsize); - Set_Enum_Esize (Enumtype); - end if; - - Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); - Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); - Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); - end; - end if; - - -- We repeat the too late test in case it froze itself! - - if Rep_Item_Too_Late (Enumtype, N) then - null; - end if; - end Analyze_Enumeration_Representation_Clause; - - ---------------------------- - -- Analyze_Free_Statement -- - ---------------------------- - - procedure Analyze_Free_Statement (N : Node_Id) is - begin - Analyze (Expression (N)); - end Analyze_Free_Statement; - - --------------------------- - -- Analyze_Freeze_Entity -- - --------------------------- - - procedure Analyze_Freeze_Entity (N : Node_Id) is - E : constant Entity_Id := Entity (N); - - begin - -- Remember that we are processing a freezing entity. Required to - -- ensure correct decoration of internal entities associated with - -- interfaces (see New_Overloaded_Entity). - - Inside_Freezing_Actions := Inside_Freezing_Actions + 1; - - -- For tagged types covering interfaces add internal entities that link - -- the primitives of the interfaces with the primitives that cover them. - -- Note: These entities were originally generated only when generating - -- code because their main purpose was to provide support to initialize - -- the secondary dispatch tables. They are now generated also when - -- compiling with no code generation to provide ASIS the relationship - -- between interface primitives and tagged type primitives. They are - -- also used to locate primitives covering interfaces when processing - -- generics (see Derive_Subprograms). - - if Ada_Version >= Ada_2005 - and then Ekind (E) = E_Record_Type - and then Is_Tagged_Type (E) - and then not Is_Interface (E) - and then Has_Interfaces (E) - then - -- This would be a good common place to call the routine that checks - -- overriding of interface primitives (and thus factorize calls to - -- Check_Abstract_Overriding located at different contexts in the - -- compiler). However, this is not possible because it causes - -- spurious errors in case of late overriding. - - Add_Internal_Interface_Entities (E); - end if; - - -- Check CPP types - - if Ekind (E) = E_Record_Type - and then Is_CPP_Class (E) - and then Is_Tagged_Type (E) - and then Tagged_Type_Expansion - and then Expander_Active - then - if CPP_Num_Prims (E) = 0 then - - -- If the CPP type has user defined components then it must import - -- primitives from C++. This is required because if the C++ class - -- has no primitives then the C++ compiler does not added the _tag - -- component to the type. - - pragma Assert (Chars (First_Entity (E)) = Name_uTag); - - if First_Entity (E) /= Last_Entity (E) then - Error_Msg_N - ("?'C'P'P type must import at least one primitive from C++", - E); - end if; - end if; - - -- Check that all its primitives are abstract or imported from C++. - -- Check also availability of the C++ constructor. - - declare - Has_Constructors : constant Boolean := Has_CPP_Constructors (E); - Elmt : Elmt_Id; - Error_Reported : Boolean := False; - Prim : Node_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); - - if Comes_From_Source (Prim) then - if Is_Abstract_Subprogram (Prim) then - null; - - elsif not Is_Imported (Prim) - or else Convention (Prim) /= Convention_CPP - then - Error_Msg_N - ("?primitives of 'C'P'P types must be imported from C++" - & " or abstract", Prim); - - elsif not Has_Constructors - and then not Error_Reported - then - Error_Msg_Name_1 := Chars (E); - Error_Msg_N - ("?'C'P'P constructor required for type %", Prim); - Error_Reported := True; - end if; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Check Ada derivation of CPP type - - if Expander_Active - and then Tagged_Type_Expansion - and then Ekind (E) = E_Record_Type - and then Etype (E) /= E - and then Is_CPP_Class (Etype (E)) - and then CPP_Num_Prims (Etype (E)) > 0 - and then not Is_CPP_Class (E) - and then not Has_CPP_Constructors (Etype (E)) - then - -- If the parent has C++ primitives but it has no constructor then - -- check that all the primitives are overridden in this derivation; - -- otherwise the constructor of the parent is needed to build the - -- dispatch table. - - declare - Elmt : Elmt_Id; - Prim : Node_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); - - if not Is_Abstract_Subprogram (Prim) - and then No (Interface_Alias (Prim)) - and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E - then - Error_Msg_Name_1 := Chars (Etype (E)); - Error_Msg_N - ("'C'P'P constructor required for parent type %", E); - exit; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - Inside_Freezing_Actions := Inside_Freezing_Actions - 1; - - -- If we have a type with predicates, build predicate function - - if Is_Type (E) and then Has_Predicates (E) then - Build_Predicate_Function (E, N); - end if; - - -- If type has delayed aspects, this is where we do the preanalysis at - -- the freeze point, as part of the consistent visibility check. Note - -- that this must be done after calling Build_Predicate_Function or - -- Build_Invariant_Procedure since these subprograms fix occurrences of - -- the subtype name in the saved expression so that they will not cause - -- trouble in the preanalysis. - - if Has_Delayed_Aspects (E) - and then Scope (E) = Current_Scope - then - -- Retrieve the visibility to the discriminants in order to properly - -- analyze the aspects. - - Push_Scope_And_Install_Discriminants (E); - - declare - Ritem : Node_Id; - - begin - -- Look for aspect specification entries for this entity - - Ritem := First_Rep_Item (E); - while Present (Ritem) loop - if Nkind (Ritem) = N_Aspect_Specification - and then Entity (Ritem) = E - and then Is_Delayed_Aspect (Ritem) - then - Check_Aspect_At_Freeze_Point (Ritem); - end if; - - Next_Rep_Item (Ritem); - end loop; + else + Set_RM_Size (Enumtype, Minsize); + Set_Enum_Esize (Enumtype); + end if; + + Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); + Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); + Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); end; + end if; - Uninstall_Discriminants_And_Pop_Scope (E); + -- We repeat the too late test in case it froze itself! + + if Rep_Item_Too_Late (Enumtype, N) then + null; end if; + end Analyze_Enumeration_Representation_Clause; + + ---------------------------- + -- Analyze_Free_Statement -- + ---------------------------- + + procedure Analyze_Free_Statement (N : Node_Id) is + begin + Analyze (Expression (N)); + end Analyze_Free_Statement; + + --------------------------- + -- Analyze_Freeze_Entity -- + --------------------------- + + procedure Analyze_Freeze_Entity (N : Node_Id) is + begin + Freeze_Entity_Checks (N); end Analyze_Freeze_Entity; + ----------------------------------- + -- Analyze_Freeze_Generic_Entity -- + ----------------------------------- + + procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is + begin + Freeze_Entity_Checks (N); + end Analyze_Freeze_Generic_Entity; + ------------------------------------------ -- Analyze_Record_Representation_Clause -- ------------------------------------------ @@ -4468,10 +5351,38 @@ package body Sem_Ch13 is Ocomp : Entity_Id; Posit : Uint; Rectype : Entity_Id; + Recdef : Node_Id; + + function Is_Inherited (Comp : Entity_Id) return Boolean; + -- True if Comp is an inherited component in a record extension + + ------------------ + -- Is_Inherited -- + ------------------ + + function Is_Inherited (Comp : Entity_Id) return Boolean is + Comp_Base : Entity_Id; + + begin + if Ekind (Rectype) = E_Record_Subtype then + Comp_Base := Original_Record_Component (Comp); + else + Comp_Base := Comp; + end if; + + return Comp_Base /= Original_Record_Component (Comp_Base); + end Is_Inherited; + + -- Local variables + + Is_Record_Extension : Boolean; + -- True if Rectype is a record extension CR_Pragma : Node_Id := Empty; -- Points to N_Pragma node if Complete_Representation pragma present + -- Start of processing for Analyze_Record_Representation_Clause + begin if Ignore_Rep_Clauses then return; @@ -4480,9 +5391,7 @@ package body Sem_Ch13 is Find_Type (Ident); Rectype := Entity (Ident); - if Rectype = Any_Type - or else Rep_Item_Too_Early (Rectype, N) - then + if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then return; else Rectype := Underlying_Type (Rectype); @@ -4511,6 +5420,14 @@ package body Sem_Ch13 is return; end if; + -- We know we have a first subtype, now possibly go the the anonymous + -- base type to determine whether Rectype is a record extension. + + Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype))); + Is_Record_Extension := + Nkind (Recdef) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Recdef)); + if Present (Mod_Clause (N)) then declare Loc : constant Source_Ptr := Sloc (N); @@ -4526,9 +5443,9 @@ package body Sem_Ch13 is if Warn_On_Obsolescent_Feature then Error_Msg_N - ("mod clause is an obsolescent feature (RM J.8)?", N); + ("?j?mod clause is an obsolescent feature (RM J.8)", N); Error_Msg_N - ("\use alignment attribute definition clause instead?", N); + ("\?j?use alignment attribute definition clause instead", N); end if; if Present (P) then @@ -4686,6 +5603,11 @@ package body Sem_Ch13 is ("cannot reference discriminant of unchecked union", Component_Name (CC)); + elsif Is_Record_Extension and then Is_Inherited (Comp) then + Error_Msg_NE + ("component clause not allowed for inherited " + & "component&", CC, Comp); + elsif Present (Component_Clause (Comp)) then -- Diagnose duplicate rep clause, or check consistency @@ -4710,11 +5632,14 @@ package body Sem_Ch13 is or else Intval (Last_Bit (Rep1)) /= Intval (Last_Bit (CC)) then - Error_Msg_N ("component clause inconsistent " - & "with representation of ancestor", CC); + Error_Msg_N + ("component clause inconsistent " + & "with representation of ancestor", CC); + elsif Warn_On_Redundant_Constructs then - Error_Msg_N ("?redundant component clause " - & "for inherited component!", CC); + Error_Msg_N + ("?r?redundant confirming component clause " + & "for component!", CC); end if; end; end if; @@ -4753,7 +5678,7 @@ package body Sem_Ch13 is and then RM_Size (Etype (Comp)) /= Esize (Comp) then Error_Msg_NE - ("?component size overrides size clause for&", + ("?S?component size overrides size clause for&", Component_Name (CC), Etype (Comp)); end if; @@ -4819,7 +5744,7 @@ package body Sem_Ch13 is Next_Component_Or_Discriminant (Comp); end loop; - -- If no Complete_Representation pragma, warn if missing components + -- Give missing components warning if required elsif Warn_On_Unrepped_Components then declare @@ -4863,7 +5788,7 @@ package body Sem_Ch13 is then Error_Msg_Sloc := Sloc (Comp); Error_Msg_NE - ("?no component clause given for & declared #", + ("?C?no component clause given for & declared #", N, Comp); end if; @@ -4874,6 +5799,47 @@ package body Sem_Ch13 is end if; end Analyze_Record_Representation_Clause; + ------------------------------------------- + -- Build_Invariant_Procedure_Declaration -- + ------------------------------------------- + + function Build_Invariant_Procedure_Declaration + (Typ : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Typ); + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + Spec : Node_Id; + SId : Entity_Id; + + begin + Set_Etype (Object_Entity, Typ); + + -- Check for duplicate definiations. + + if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then + return Empty; + end if; + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Invariant")); + Set_Has_Invariants (Typ); + Set_Ekind (SId, E_Procedure); + Set_Is_Invariant_Procedure (SId); + Set_Invariant_Procedure (Typ, SId); + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + return Make_Subprogram_Declaration (Loc, Specification => Spec); + end Build_Invariant_Procedure_Declaration; + ------------------------------- -- Build_Invariant_Procedure -- ------------------------------- @@ -4908,12 +5874,11 @@ package body Sem_Ch13 is -- "inherited" to the exception message and generating an informational -- message about the inheritance of an invariant. - Object_Name : constant Name_Id := New_Internal_Name ('I'); + Object_Name : Name_Id; -- Name for argument of invariant procedure - Object_Entity : constant Node_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The procedure declaration entity for the argument + Object_Entity : Node_Id; + -- The entity of the formal for the procedure -------------------- -- Add_Invariants -- @@ -4948,18 +5913,21 @@ package body Sem_Ch13 is -- Replace_Type_Reference -- ---------------------------- + -- Note: See comments in Add_Predicates.Replace_Type_Reference + -- regarding handling of Sloc and Comes_From_Source. + procedure Replace_Type_Reference (N : Node_Id) is begin -- Invariant'Class, replace with T'Class (obj) if Class_Present (Ritem) then Rewrite (N, - Make_Type_Conversion (Loc, + Make_Type_Conversion (Sloc (N), Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (T, Loc), + Make_Attribute_Reference (Sloc (N), + Prefix => New_Occurrence_Of (T, Sloc (N)), Attribute_Name => Name_Class), - Expression => Make_Identifier (Loc, Object_Name))); + Expression => Make_Identifier (Sloc (N), Object_Name))); Set_Entity (Expression (N), Object_Entity); Set_Etype (Expression (N), Typ); @@ -4967,10 +5935,12 @@ package body Sem_Ch13 is -- Invariant, replace with obj else - Rewrite (N, Make_Identifier (Loc, Object_Name)); + Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); Set_Entity (N, Object_Entity); Set_Etype (N, Typ); end if; + + Set_Comes_From_Source (N, True); end Replace_Type_Reference; -- Start of processing for Add_Invariants @@ -5008,7 +5978,10 @@ package body Sem_Ch13 is end if; Exp := New_Copy_Tree (Arg2); - Loc := Sloc (Exp); + + -- Preserve sloc of original pragma Invariant + + Loc := Sloc (Ritem); -- We need to replace any occurrences of the name of the type -- with references to the object, converted to type'Class in @@ -5058,7 +6031,8 @@ package body Sem_Ch13 is Assoc := New_List ( Make_Pragma_Argument_Association (Loc, Expression => Make_Identifier (Loc, Name_Invariant)), - Make_Pragma_Argument_Association (Loc, Expression => Exp)); + Make_Pragma_Argument_Association (Loc, + Expression => Exp)); -- Add message if present in Invariant pragma @@ -5096,7 +6070,7 @@ package body Sem_Ch13 is if Inherit and Opt.List_Inherited_Aspects then Error_Msg_Sloc := Sloc (Ritem); Error_Msg_N - ("?info: & inherits `Invariant''Class` aspect from #", + ("?L?info: & inherits `Invariant''Class` aspect from #", Typ); end if; end if; @@ -5112,7 +6086,28 @@ package body Sem_Ch13 is Stmts := No_List; PDecl := Empty; PBody := Empty; - Set_Etype (Object_Entity, Typ); + SId := Empty; + + -- If the aspect specification exists for some view of the type, the + -- declaration for the procedure has been created. + + if Has_Invariants (Typ) then + SId := Invariant_Procedure (Typ); + end if; + + if Present (SId) then + PDecl := Unit_Declaration_Node (SId); + else + PDecl := Build_Invariant_Procedure_Declaration (Typ); + end if; + + -- Recover formal of procedure, for use in the calls to invariant + -- functions (including inherited ones). + + Object_Entity := + Defining_Identifier + (First (Parameter_Specifications (Specification (PDecl)))); + Object_Name := Chars (Object_Entity); -- Add invariants for the current type @@ -5145,39 +6140,7 @@ package body Sem_Ch13 is -- Build the procedure if we generated at least one Check pragma if Stmts /= No_List then - - -- Build procedure declaration - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - Set_Has_Invariants (SId); - Set_Invariant_Procedure (Typ, SId); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); - - PDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); - - -- Build procedure body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Invariant")); - - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + Spec := Copy_Separate_Tree (Specification (PDecl)); PBody := Make_Subprogram_Body (Loc, @@ -5188,14 +6151,18 @@ package body Sem_Ch13 is Statements => Stmts)); -- Insert procedure declaration and spec at the appropriate points. + -- If declaration is already analyzed, it was processed by the + -- generated pragma. if Present (Private_Decls) then -- The spec goes at the end of visible declarations, but they have -- already been analyzed, so we need to explicitly do the analyze. - Append_To (Visible_Decls, PDecl); - Analyze (PDecl); + if not Analyzed (PDecl) then + Append_To (Visible_Decls, PDecl); + Analyze (PDecl); + end if; -- The body goes at the end of the private declarations, which we -- have not analyzed yet, so we do not need to perform an explicit @@ -5228,11 +6195,11 @@ package body Sem_Ch13 is end if; end Build_Invariant_Procedure; - ------------------------------ - -- Build_Predicate_Function -- - ------------------------------ + ------------------------------- + -- Build_Predicate_Functions -- + ------------------------------- - -- The procedure that is constructed here has the form: + -- The procedures that are constructed here have the form: -- function typPredicate (Ixxx : typ) return Boolean is -- begin @@ -5249,17 +6216,41 @@ package body Sem_Ch13 is -- inherited. Note that we do NOT generate Check pragmas, that's because we -- use this function even if checks are off, e.g. for membership tests. - procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ); - Spec : Node_Id; - SId : Entity_Id; - FDecl : Node_Id; - FBody : Node_Id; + -- If the expression has at least one Raise_Expression, then we also build + -- the typPredicateM version of the function, in which any occurrence of a + -- Raise_Expression is converted to "return False". + + procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is + Loc : constant Source_Ptr := Sloc (Typ); Expr : Node_Id; - -- This is the expression for the return statement in the function. It + -- This is the expression for the result of the function. It is -- is build by connecting the component predicates with AND THEN. + Expr_M : Node_Id; + -- This is the corresponding return expression for the Predicate_M + -- function. It differs in that raise expressions are marked for + -- special expansion (see Process_REs). + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure. Note that we use the same + -- name for both predicate procedure. That way the reference within the + -- predicate expression is the same in both functions. + + Object_Entity : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate procedure + + Object_Entity_M : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars => Object_Name); + -- Entity for argument of Predicate_M procedure + + Raise_Expression_Present : Boolean := False; + -- Set True if Expr has at least one Raise_Expression + + Static_Predic : Node_Id := Empty; + -- Set to N_Pragma node for a static predicate if one is encountered + procedure Add_Call (T : Entity_Id); -- Includes a call to the predicate function for type T in Expr if T -- has predicates and Predicate_Function (T) is non-empty. @@ -5270,19 +6261,19 @@ package body Sem_Ch13 is -- Inheritance of predicates for the parent type is done by calling the -- Predicate_Function of the parent type, using Add_Call above. - Object_Name : constant Name_Id := New_Internal_Name ('I'); - -- Name for argument of Predicate procedure + function Test_RE (N : Node_Id) return Traverse_Result; + -- Used in Test_REs, tests one node for being a raise expression, and if + -- so sets Raise_Expression_Present True. - Object_Entity : constant Entity_Id := - Make_Defining_Identifier (Loc, Object_Name); - -- The entity for the spec entity for the argument + procedure Test_REs is new Traverse_Proc (Test_RE); + -- Tests to see if Expr contains any raise expressions - Dynamic_Predicate_Present : Boolean := False; - -- Set True if a dynamic predicate is present, results in the entire - -- predicate being considered dynamic even if it looks static + function Process_RE (N : Node_Id) return Traverse_Result; + -- Used in Process REs, tests if node N is a raise expression, and if + -- so, marks it to be converted to return False. - Static_Predicate_Present : Node_Id := Empty; - -- Set to N_Pragma node for a static predicate if one is encountered. + procedure Process_REs is new Traverse_Proc (Process_RE); + -- Marks any raise expressions in Expr_M to return False -------------- -- Add_Call -- @@ -5326,7 +6317,7 @@ package body Sem_Ch13 is then Error_Msg_Sloc := Sloc (Predicate_Function (T)); Error_Msg_Node_2 := T; - Error_Msg_N ("?info: & inherits predicate from & #", Typ); + Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); end if; end if; end Add_Call; @@ -5358,9 +6349,16 @@ package body Sem_Ch13 is procedure Replace_Type_Reference (N : Node_Id) is begin - Rewrite (N, Make_Identifier (Loc, Object_Name)); - Set_Entity (N, Object_Entity); + Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); + -- Use the Sloc of the usage name, not the defining name + Set_Etype (N, Typ); + Set_Entity (N, Object_Entity); + + -- We want to treat the node as if it comes from source, so that + -- ASIS will not ignore it + + Set_Comes_From_Source (N, True); end Replace_Type_Reference; -- Start of processing for Add_Predicates @@ -5371,15 +6369,14 @@ package body Sem_Ch13 is if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then - 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; + -- Save the static predicate of the type for diagnostics and + -- error reporting purposes. + + if Present (Corresponding_Aspect (Ritem)) + and then Chars (Identifier (Corresponding_Aspect (Ritem))) = + Name_Static_Predicate + then + Static_Predic := Ritem; end if; -- Acquire arguments @@ -5398,7 +6395,6 @@ package body Sem_Ch13 is if Entity (Arg1) = Typ or else Full_View (Entity (Arg1)) = Typ then - -- We have a match, this entry is for our subtype -- We need to replace any occurrences of the name of the @@ -5455,13 +6451,37 @@ package body Sem_Ch13 is end loop; end Add_Predicates; - -- Start of processing for Build_Predicate_Function + ---------------- + -- Process_RE -- + ---------------- - begin - -- Initialize for construction of statement list + function Process_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Set_Convert_To_Return_False (N); + return Skip; + else + return OK; + end if; + end Process_RE; - Expr := Empty; + ------------- + -- Test_RE -- + ------------- + + function Test_RE (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Raise_Expression then + Raise_Expression_Present := True; + return Abandon; + else + return OK; + end if; + end Test_RE; + -- Start of processing for Build_Predicate_Functions + + begin -- Return if already built or if type does not have predicates if not Has_Predicates (Typ) @@ -5470,6 +6490,10 @@ package body Sem_Ch13 is return; end if; + -- Prepare to construct predicate expression + + Expr := Empty; + -- Add Predicates for the current type Add_Predicates; @@ -5484,92 +6508,248 @@ package body Sem_Ch13 is end if; end; - -- If we have predicates, build the function + -- Case where predicates are present if Present (Expr) then - -- Build function declaration + -- Test for raise expression present - pragma Assert (Has_Predicates (Typ)); - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - Set_Has_Predicates (SId); - Set_Predicate_Function (Typ, SId); + Test_REs (Expr); - -- The predicate function is shared between views of a type. + -- If raise expression is present, capture a copy of Expr for use + -- in building the predicateM function version later on. For this + -- copy we replace references to Object_Entity by Object_Entity_M. - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function (Full_View (Typ), SId); + if Raise_Expression_Present then + declare + Map : constant Elist_Id := New_Elmt_List; + begin + Append_Elmt (Object_Entity, Map); + Append_Elmt (Object_Entity_M, Map); + Expr_M := New_Copy_Tree (Expr, Map => Map); + end; end if; - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Object_Entity, - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); - - -- Build function body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); + -- Build the main predicate function - -- Insert declaration before freeze node and body after + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the the function spec - Insert_Before_And_Analyze (N, FDecl); - Insert_After_And_Analyze (N, FBody); + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + -- The entity for the function body - -- Deal with static predicate case + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; - if Ekind_In (Typ, E_Enumeration_Subtype, - E_Modular_Integer_Subtype, - E_Signed_Integer_Subtype) - and then Is_Static_Subtype (Typ) - and then not Dynamic_Predicate_Present - then - Build_Static_Predicate (Typ, Expr, Object_Name); + begin + -- Build function declaration + + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function (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, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body - if Present (Static_Predicate_Present) - and No (Static_Predicate (Typ)) + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + + -- Test for raise expressions present and if so build M version + + if Raise_Expression_Present then + declare + SId : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the the function spec + + SIdB : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "PredicateM")); + -- The entity for the function body + + Spec : Node_Id; + FDecl : Node_Id; + FBody : Node_Id; + BTemp : Entity_Id; + + begin + -- Mark any raise expressions for special expansion + + Process_REs (Expr_M); + + -- Build function declaration + + Set_Ekind (SId, E_Function); + Set_Is_Predicate_Function_M (SId); + Set_Predicate_Function_M (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_M (Full_View (Typ), SId); + end if; + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Object_Entity_M, + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SIdB, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + -- Build the body, we declare the boolean expression before + -- doing the return, because we are not really confident of + -- what happens if a return appears within a return! + + BTemp := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('B')); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => BTemp, + Constant_Present => True, + Object_Definition => + New_Reference_To (Standard_Boolean, Loc), + Expression => Expr_M)), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (BTemp, Loc))))); + + -- Insert declaration before freeze node and body after + + Insert_Before_And_Analyze (N, FDecl); + Insert_After_And_Analyze (N, FBody); + end; + end if; + + if Is_Scalar_Type (Typ) then + + -- Attempt to build a static predicate for a discrete or a real + -- subtype. This action may fail because the actual expression may + -- not be static. Note that the presence of an inherited or + -- explicitly declared dynamic predicate is orthogonal to this + -- check because we are only interested in the static predicate. + + if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype, + E_Enumeration_Subtype, + E_Floating_Point_Subtype, + E_Modular_Integer_Subtype, + E_Ordinary_Fixed_Point_Subtype, + E_Signed_Integer_Subtype) then - Error_Msg_F - ("expression does not have required form for " - & "static predicate", - Next (First (Pragma_Argument_Associations - (Static_Predicate_Present)))); + Build_Static_Predicate (Typ, Expr, Object_Name); + + -- Emit an error when the predicate is categorized as static + -- but its expression is dynamic. + + if Present (Static_Predic) + and then No (Static_Predicate (Typ)) + then + Error_Msg_F + ("expression does not have required form for " + & "static predicate", + Next (First (Pragma_Argument_Associations + (Static_Predic)))); + end if; + end if; + + -- If a static predicate applies on other types, that's an error: + -- either the type is scalar but non-static, or it's not even a + -- scalar type. We do not issue an error on generated types, as + -- these may be duplicates of the same error on a source type. + + elsif Present (Static_Predic) and then Comes_From_Source (Typ) then + if Is_Scalar_Type (Typ) then + Error_Msg_FE + ("static predicate not allowed for non-static type&", + Typ, Typ); + else + Error_Msg_FE + ("static predicate not allowed for non-scalar type&", + Typ, Typ); end if; end if; end if; - end Build_Predicate_Function; + end Build_Predicate_Functions; ---------------------------- -- Build_Static_Predicate -- @@ -5598,15 +6778,15 @@ package body Sem_Ch13 is type REnt is record Lo, Hi : Uint; end record; - -- One entry in a Rlist value, a single REnt (range entry) value - -- denotes one range from Lo to Hi. To represent a single value - -- range Lo = Hi = value. + -- One entry in a Rlist value, a single REnt (range entry) value denotes + -- one range from Lo to Hi. To represent a single value range Lo = Hi = + -- value. type RList is array (Nat range <>) of REnt; - -- A list of ranges. The ranges are sorted in increasing order, - -- and are disjoint (there is a gap of at least one value between - -- each range in the table). A value is in the set of ranges in - -- Rlist if it lies within one of these ranges + -- A list of ranges. The ranges are sorted in increasing order, and are + -- disjoint (there is a gap of at least one value between each range in + -- the table). A value is in the set of ranges in Rlist if it lies + -- within one of these ranges. False_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); @@ -5620,41 +6800,41 @@ package body Sem_Ch13 is True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); -- Range representing True, value must be in the base range - function "and" (Left, Right : RList) return RList; - -- And's together two range lists, returning a range list. This is - -- a set intersection operation. + function "and" (Left : RList; Right : RList) return RList; + -- And's together two range lists, returning a range list. This is a set + -- intersection operation. - function "or" (Left, Right : RList) return RList; - -- Or's together two range lists, returning a range list. This is a - -- set union operation. + function "or" (Left : RList; Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a set + -- union operation. function "not" (Right : RList) return RList; -- Returns complement of a given range list, i.e. a range list - -- representing all the values in TLo .. THi that are not in the - -- input operand Right. + -- representing all the values in TLo .. THi that are not in the input + -- operand Right. function Build_Val (V : Uint) return Node_Id; -- Return an analyzed N_Identifier node referencing this value, suitable -- for use as an entry in the Static_Predicate list. This node is typed -- with the base type. - function Build_Range (Lo, Hi : Uint) return Node_Id; - -- Return an analyzed N_Range node referencing this range, suitable - -- for use as an entry in the Static_Predicate list. This node is typed - -- with the base type. + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable for + -- use as an entry in the Static_Predicate list. This node is typed with + -- the base type. function Get_RList (Exp : Node_Id) return RList; - -- This is a recursive routine that converts the given expression into - -- a list of ranges, suitable for use in building the static predicate. + -- This is a recursive routine that converts the given expression into a + -- list of ranges, suitable for use in building the static predicate. function Is_False (R : RList) return Boolean; pragma Inline (Is_False); - -- Returns True if the given range list is empty, and thus represents - -- a False list of ranges that can never be satisfied. + -- Returns True if the given range list is empty, and thus represents a + -- False list of ranges that can never be satisfied. function Is_True (R : RList) return Boolean; - -- Returns True if R trivially represents the True predicate by having - -- a single range from BLo to BHi. + -- Returns True if R trivially represents the True predicate by having a + -- single range from BLo to BHi. function Is_Type_Ref (N : Node_Id) return Boolean; pragma Inline (Is_Type_Ref); @@ -5687,7 +6867,7 @@ package body Sem_Ch13 is -- "and" -- ----------- - function "and" (Left, Right : RList) return RList is + function "and" (Left : RList; Right : RList) return RList is FEnt : REnt; -- First range of result @@ -5712,8 +6892,8 @@ package body Sem_Ch13 is return False_Range; end if; - -- Loop to remove entries at start that are disjoint, and thus - -- just get discarded from the result entirely. + -- Loop to remove entries at start that are disjoint, and thus just + -- get discarded from the result entirely. loop -- If no operands left in either operand, result is false @@ -5738,15 +6918,15 @@ package body Sem_Ch13 is end if; end loop; - -- Now we have two non-null operands, and first entries overlap. - -- The first entry in the result will be the overlapping part of - -- these two entries. + -- Now we have two non-null operands, and first entries overlap. The + -- first entry in the result will be the overlapping part of these + -- two entries. FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); - -- Now we can remove the entry that ended at a lower value, since - -- its contribution is entirely contained in Fent. + -- Now we can remove the entry that ended at a lower value, since its + -- contribution is entirely contained in Fent. if Left (SLeft).Hi <= Right (SRight).Hi then SLeft := SLeft + 1; @@ -5754,10 +6934,10 @@ package body Sem_Ch13 is SRight := SRight + 1; end if; - -- Compute result by concatenating this first entry with the "and" - -- of the remaining parts of the left and right operands. Note that - -- if either of these is empty, "and" will yield empty, so that we - -- will end up with just Fent, which is what we want in that case. + -- Compute result by concatenating this first entry with the "and" of + -- the remaining parts of the left and right operands. Note that if + -- either of these is empty, "and" will yield empty, so that we will + -- end up with just Fent, which is what we want in that case. return FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); @@ -5821,7 +7001,7 @@ package body Sem_Ch13 is -- "or" -- ---------- - function "or" (Left, Right : RList) return RList is + function "or" (Left : RList; Right : RList) return RList is FEnt : REnt; -- First range of result @@ -5846,8 +7026,8 @@ package body Sem_Ch13 is return Left; end if; - -- Initialize result first entry from left or right operand - -- depending on which starts with the lower range. + -- Initialize result first entry from left or right operand depending + -- on which starts with the lower range. if Left (SLeft).Lo < Right (SRight).Lo then FEnt := Left (SLeft); @@ -5857,12 +7037,12 @@ package body Sem_Ch13 is SRight := SRight + 1; end if; - -- This loop eats ranges from left and right operands that - -- are contiguous with the first range we are gathering. + -- This loop eats ranges from left and right operands that are + -- contiguous with the first range we are gathering. loop - -- Eat first entry in left operand if contiguous or - -- overlapped by gathered first operand of result. + -- Eat first entry in left operand if contiguous or overlapped by + -- gathered first operand of result. if SLeft <= Left'Last and then Left (SLeft).Lo <= FEnt.Hi + 1 @@ -5870,8 +7050,8 @@ package body Sem_Ch13 is FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); SLeft := SLeft + 1; - -- Eat first entry in right operand if contiguous or - -- overlapped by gathered right operand of result. + -- Eat first entry in right operand if contiguous or overlapped by + -- gathered right operand of result. elsif SRight <= Right'Last and then Right (SRight).Lo <= FEnt.Hi + 1 @@ -5879,7 +7059,7 @@ package body Sem_Ch13 is FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); SRight := SRight + 1; - -- All done if no more entries to eat! + -- All done if no more entries to eat else exit; @@ -5898,20 +7078,18 @@ package body Sem_Ch13 is -- Build_Range -- ----------------- - function Build_Range (Lo, Hi : Uint) return Node_Id is + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is Result : Node_Id; + begin - if Lo = Hi then - return Build_Val (Hi); - else - Result := - Make_Range (Loc, - Low_Bound => Build_Val (Lo), - High_Bound => Build_Val (Hi)); - Set_Etype (Result, Btyp); - Set_Analyzed (Result); - return Result; - end if; + Result := + Make_Range (Loc, + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Btyp); + Set_Analyzed (Result); + + return Result; end Build_Range; --------------- @@ -5984,6 +7162,7 @@ package body Sem_Ch13 is -- Comparisons of type with static value when N_Op_Compare => + -- Type is left operand if Is_Type_Ref (Left_Opnd (Exp)) @@ -6073,7 +7252,10 @@ package body Sem_Ch13 is declare Ent : constant Entity_Id := Entity (Name (Exp)); begin - if Has_Predicates (Ent) then + if Is_Predicate_Function (Ent) + or else + Is_Predicate_Function_M (Ent) + then return Stat_Pred (Etype (First_Formal (Ent))); end if; end; @@ -6088,6 +7270,16 @@ package body Sem_Ch13 is when N_Qualified_Expression => return Get_RList (Expression (Exp)); + -- Expression with actions: if no actions, dig out expression + + when N_Expression_With_Actions => + if Is_Empty_List (Actions (Exp)) then + return Get_RList (Expression (Exp)); + + else + raise Non_Static; + end if; + -- Xor operator when N_Op_Xor => @@ -6246,9 +7438,7 @@ package body Sem_Ch13 is begin -- Not static if type does not have static predicates - if not Has_Predicates (Typ) - or else No (Static_Predicate (Typ)) - then + if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then raise Non_Static; end if; @@ -6319,11 +7509,7 @@ package body Sem_Ch13 is -- Convert range into required form - if Lo = Hi then - Append_To (Plist, Build_Val (Lo)); - else - Append_To (Plist, Build_Range (Lo, Hi)); - end if; + Append_To (Plist, Build_Range (Lo, Hi)); end if; end; end loop; @@ -6531,7 +7717,7 @@ package body Sem_Ch13 is ("visibility of aspect for& changes after freeze point", ASN, Ent); Error_Msg_NE - ("?info: & is frozen here, aspects evaluated at this point", + ("info: & is frozen here, aspects evaluated at this point??", Freeze_Node (Ent), Ent); end if; end Check_Aspect_At_End_Of_Declarations; @@ -6557,7 +7743,7 @@ package body Sem_Ch13 is -- containing that copy, but Expression (Ident) is a preanalyzed copy -- of the expression, preanalyzed just after the freeze point. - -- Make a copy of the expression to be preanalyed + -- Make a copy of the expression to be preanalyzed Set_Expression (ASN, New_Copy_Tree (Entity (Ident))); @@ -6574,34 +7760,43 @@ package body Sem_Ch13 is when Boolean_Aspects | Library_Unit_Aspects => + T := Standard_Boolean; + -- Aspects corresponding to attribute definition clauses + + when Aspect_Address => + T := RTE (RE_Address); + when Aspect_Attach_Handler => T := RTE (RE_Interrupt_ID); + when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => + T := RTE (RE_Bit_Order); + when Aspect_Convention => return; - -- Default_Value is resolved with the type entity in question - - when Aspect_Default_Value => - T := Entity (ASN); + when Aspect_CPU => + T := RTE (RE_CPU_Range); -- Default_Component_Value is resolved with the component type when Aspect_Default_Component_Value => T := Component_Type (Entity (ASN)); - -- Aspects corresponding to attribute definition clauses + -- Default_Value is resolved with the type entity in question - when Aspect_Address => - T := RTE (RE_Address); + when Aspect_Default_Value => + T := Entity (ASN); - when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => - T := RTE (RE_Bit_Order); + -- Depends is a delayed aspect because it mentiones names first + -- introduced by aspect Global which is already delayed. There is + -- no action to be taken with respect to the aspect itself as the + -- analysis is done by the corresponding pragma. - when Aspect_CPU => - T := RTE (RE_CPU_Range); + when Aspect_Depends => + return; when Aspect_Dispatching_Domain => T := RTE (RE_Dispatching_Domain); @@ -6612,12 +7807,23 @@ package body Sem_Ch13 is when Aspect_External_Name => T := Standard_String; + -- Global is a delayed aspect because it may reference names that + -- have not been declared yet. There is no action to be taken with + -- respect to the aspect itself as the reference checking is done + -- on the corresponding pragma. + + when Aspect_Global => + return; + when Aspect_Link_Name => T := Standard_String; when Aspect_Priority | Aspect_Interrupt_Priority => T := Standard_Integer; + when Aspect_Relative_Deadline => + T := RTE (RE_Time_Span); + when Aspect_Small => T := Universal_Real; @@ -6676,17 +7882,25 @@ package body Sem_Ch13 is Aspect_Type_Invariant => T := Standard_Boolean; - -- Here is the list of aspects that don't require delay analysis. + -- Here is the list of aspects that don't require delay analysis - when Aspect_Contract_Case | + when Aspect_Abstract_State | + Aspect_Contract_Cases | Aspect_Dimension | Aspect_Dimension_System | Aspect_Implicit_Dereference | + Aspect_Initial_Condition | + Aspect_Initializes | Aspect_Post | Aspect_Postcondition | Aspect_Pre | Aspect_Precondition | - Aspect_Test_Case => + Aspect_Refined_Depends | + Aspect_Refined_Global | + Aspect_Refined_Post | + Aspect_Refined_State | + Aspect_SPARK_Mode | + Aspect_Test_Case => raise Program_Error; end case; @@ -6931,13 +8145,10 @@ package body Sem_Ch13 is Check_Expr_Constants (Prefix (Nod)); when N_Attribute_Reference => - if Attribute_Name (Nod) = Name_Address - or else - Attribute_Name (Nod) = Name_Access - or else - Attribute_Name (Nod) = Name_Unchecked_Access - or else - Attribute_Name (Nod) = Name_Unrestricted_Access + if Nam_In (Attribute_Name (Nod), Name_Address, + Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then Check_At_Constant_Address (Prefix (Nod)); @@ -6970,28 +8181,10 @@ package body Sem_Ch13 is when N_Type_Conversion | N_Qualified_Expression | - N_Allocator => - Check_Expr_Constants (Expression (Nod)); - - when N_Unchecked_Type_Conversion => + N_Allocator | + N_Unchecked_Type_Conversion => Check_Expr_Constants (Expression (Nod)); - -- If this is a rewritten unchecked conversion, subtypes in - -- this node are those created within the instance. To avoid - -- order of elaboration issues, replace them with their base - -- types. Note that address clauses can cause order of - -- elaboration problems because they are elaborated by the - -- back-end at the point of definition, and may mention - -- entities declared in between (as long as everything is - -- static). It is user-friendly to allow unchecked conversions - -- in this context. - - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Expression (Nod), - Base_Type (Etype (Expression (Nod)))); - Set_Etype (Nod, Base_Type (Etype (Nod))); - end if; - when N_Function_Call => if not Is_Pure (Entity (Name (Nod))) then Error_Msg_NE @@ -7116,14 +8309,11 @@ package body Sem_Ch13 is begin if Present (CC1) and then Present (CC2) then - -- Exclude odd case where we have two tag fields in the same + -- Exclude odd case where we have two tag components in the same -- record, both at location zero. This seems a bit strange, but -- it seems to happen in some circumstances, perhaps on an error. - if Chars (C1_Ent) = Name_uTag - and then - Chars (C2_Ent) = Name_uTag - then + if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then return; end if; @@ -7157,7 +8347,7 @@ package body Sem_Ch13 is procedure Find_Component is procedure Search_Component (R : Entity_Id); - -- Search components of R for a match. If found, Comp is set. + -- Search components of R for a match. If found, Comp is set ---------------------- -- Search_Component -- @@ -7196,8 +8386,8 @@ package body Sem_Ch13 is Search_Component (Rectype); - -- If not found, maybe component of base type that is absent from - -- statically constrained first subtype. + -- If not found, maybe component of base type discriminant that is + -- absent from statically constrained first subtype. if No (Comp) then Search_Component (Base_Type (Rectype)); @@ -7207,9 +8397,8 @@ package body Sem_Ch13 is -- clause in question, then there was some previous error for which -- we already gave a message, so just return with Comp Empty. - if No (Comp) - or else Component_Clause (Comp) /= CC - then + if No (Comp) or else Component_Clause (Comp) /= CC then + Check_Error_Detected; Comp := Empty; -- Normal case where we have a component clause @@ -7326,7 +8515,7 @@ package body Sem_Ch13 is ("bit number out of range of specified size", Last_Bit (CC)); - -- Check for overlap with tag field + -- Check for overlap with tag component else if Is_Tagged_Type (Rectype) @@ -7345,9 +8534,7 @@ package body Sem_Ch13 is -- Check parent overlap if component might overlap parent field - if Present (Tagged_Parent) - and then Fbit <= Parent_Last_Bit - then + if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then Pcomp := First_Component_Or_Discriminant (Tagged_Parent); while Present (Pcomp) loop if not Is_Tag (Pcomp) @@ -7509,7 +8696,7 @@ package body Sem_Ch13 is -- Outer level of record definition, check discriminants if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) + N_Private_Type_Declaration) then if Has_Discriminants (Defining_Identifier (Clist)) then C2_Ent := @@ -7707,7 +8894,7 @@ package body Sem_Ch13 is if Error_Msg_Uint_1 > 0 then Error_Msg_NE - ("?^-bit gap before component&", + ("?H?^-bit gap before component&", Component_Name (Component_Clause (CEnt)), CEnt); end if; @@ -7814,13 +9001,20 @@ package body Sem_Ch13 is end if; end if; - -- Dismiss cases for generic types or types with previous errors + -- Dismiss generic types + + if Is_Generic_Type (T) + or else + Is_Generic_Type (UT) + or else + Is_Generic_Type (Root_Type (UT)) + then + return; + + -- Guard against previous errors - if No (UT) - or else UT = Any_Type - or else Is_Generic_Type (UT) - or else Is_Generic_Type (Root_Type (UT)) - then + elsif No (UT) or else UT = Any_Type then + Check_Error_Detected; return; -- Check case of bit packed array @@ -7861,6 +9055,7 @@ package body Sem_Ch13 is if Asiz <= Siz then return; + else Error_Msg_Uint_1 := Asiz; Error_Msg_NE @@ -7917,6 +9112,369 @@ package body Sem_Ch13 is end if; end Check_Size; + -------------------------- + -- Freeze_Entity_Checks -- + -------------------------- + + procedure Freeze_Entity_Checks (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; + -- True in non-generic case. Some of the processing here is skipped + -- for the generic case since it is not needed. Basically in the + -- generic case, we only need to do stuff that might generate error + -- messages or warnings. + begin + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + + -- For tagged types covering interfaces add internal entities that link + -- the primitives of the interfaces with the primitives that cover them. + -- Note: These entities were originally generated only when generating + -- code because their main purpose was to provide support to initialize + -- the secondary dispatch tables. They are now generated also when + -- compiling with no code generation to provide ASIS the relationship + -- between interface primitives and tagged type primitives. They are + -- also used to locate primitives covering interfaces when processing + -- generics (see Derive_Subprograms). + + -- This is not needed in the generic case + + if Ada_Version >= Ada_2005 + and then Non_Generic_Case + and then Ekind (E) = E_Record_Type + and then Is_Tagged_Type (E) + and then not Is_Interface (E) + and then Has_Interfaces (E) + then + -- This would be a good common place to call the routine that checks + -- overriding of interface primitives (and thus factorize calls to + -- Check_Abstract_Overriding located at different contexts in the + -- compiler). However, this is not possible because it causes + -- spurious errors in case of late overriding. + + Add_Internal_Interface_Entities (E); + end if; + + -- Check CPP types + + if Ekind (E) = E_Record_Type + and then Is_CPP_Class (E) + and then Is_Tagged_Type (E) + and then Tagged_Type_Expansion + then + if CPP_Num_Prims (E) = 0 then + + -- If the CPP type has user defined components then it must import + -- primitives from C++. This is required because if the C++ class + -- has no primitives then the C++ compiler does not added the _tag + -- component to the type. + + if First_Entity (E) /= Last_Entity (E) then + Error_Msg_N + ("'C'P'P type must import at least one primitive from C++??", + E); + end if; + end if; + + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. + + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; + + elsif not Is_Imported (Prim) + or else Convention (Prim) /= Convention_CPP + then + Error_Msg_N + ("primitives of 'C'P'P types must be imported from C++ " + & "or abstract??", Prim); + + elsif not Has_Constructors + and then not Error_Reported + then + Error_Msg_Name_1 := Chars (E); + Error_Msg_N + ("??'C'P'P constructor required for type %", Prim); + Error_Reported := True; + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Check Ada derivation of CPP type + + if Expander_Active -- why? losing errors in -gnatc mode??? + and then Tagged_Type_Expansion + and then Ekind (E) = E_Record_Type + and then Etype (E) /= E + and then Is_CPP_Class (Etype (E)) + and then CPP_Num_Prims (Etype (E)) > 0 + and then not Is_CPP_Class (E) + and then not Has_CPP_Constructors (Etype (E)) + then + -- If the parent has C++ primitives but it has no constructor then + -- check that all the primitives are overridden in this derivation; + -- otherwise the constructor of the parent is needed to build the + -- dispatch table. + + declare + Elmt : Elmt_Id; + Prim : Node_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); + + if not Is_Abstract_Subprogram (Prim) + and then No (Interface_Alias (Prim)) + and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E + then + Error_Msg_Name_1 := Chars (Etype (E)); + Error_Msg_N + ("'C'P'P constructor required for parent type %", E); + exit; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + + -- If we have a type with predicates, build predicate function. This + -- is not needed in the generic casee + + if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then + Build_Predicate_Functions (E, N); + end if; + + -- If type has delayed aspects, this is where we do the preanalysis at + -- the freeze point, as part of the consistent visibility check. Note + -- that this must be done after calling Build_Predicate_Functions or + -- Build_Invariant_Procedure since these subprograms fix occurrences of + -- the subtype name in the saved expression so that they will not cause + -- trouble in the preanalysis. + + -- This is also not needed in the generic case + + if Non_Generic_Case + and then Has_Delayed_Aspects (E) + and then Scope (E) = Current_Scope + then + -- Retrieve the visibility to the discriminants in order to properly + -- analyze the aspects. + + Push_Scope_And_Install_Discriminants (E); + + declare + Ritem : Node_Id; + + begin + -- Look for aspect specification entries for this entity + + Ritem := First_Rep_Item (E); + while Present (Ritem) loop + if Nkind (Ritem) = N_Aspect_Specification + and then Entity (Ritem) = E + and then Is_Delayed_Aspect (Ritem) + then + Check_Aspect_At_Freeze_Point (Ritem); + end if; + + Next_Rep_Item (Ritem); + end loop; + end; + + Uninstall_Discriminants_And_Pop_Scope (E); + end if; + + -- For a record type, deal with variant parts. This has to be delayed + -- to this point, because of the issue of statically precicated + -- subtypes, which we have to ensure are frozen before checking + -- choices, since we need to have the static choice list set. + + if Is_Record_Type (E) then + Check_Variant_Part : declare + D : constant Node_Id := Declaration_Node (E); + T : Node_Id; + C : Node_Id; + VP : Node_Id; + + Others_Present : Boolean; + pragma Warnings (Off, Others_Present); + -- Indicates others present, not used in this case + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the variant part has a non static choice. + + procedure Process_Declarations (Variant : Node_Id); + -- Processes declarations associated with a variant. We analyzed + -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part), + -- but we still need the recursive call to Check_Choices for any + -- nested variant to get its choices properly processed. This is + -- also where we expand out the choices if expansion is active. + + package Variant_Choices_Processing is new + Generic_Check_Choices + (Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => Process_Declarations); + use Variant_Choices_Processing; + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in variant part is not static!", Choice); + end Non_Static_Choice_Error; + + -------------------------- + -- Process_Declarations -- + -------------------------- + + procedure Process_Declarations (Variant : Node_Id) is + CL : constant Node_Id := Component_List (Variant); + VP : Node_Id; + + begin + -- Check for static predicate present in this variant + + if Has_SP_Choice (Variant) then + + -- Here we expand. You might expect to find this call in + -- Expand_N_Variant_Part, but that is called when we first + -- see the variant part, and we cannot do this expansion + -- earlier than the freeze point, since for statically + -- predicated subtypes, the predicate is not known till + -- the freeze point. + + -- Furthermore, we do this expansion even if the expander + -- is not active, because other semantic processing, e.g. + -- for aggregates, requires the expanded list of choices. + + -- If the expander is not active, then we can't just clobber + -- the list since it would invalidate the ASIS -gnatct tree. + -- So we have to rewrite the variant part with a Rewrite + -- call that replaces it with a copy and clobber the copy. + + if not Expander_Active then + declare + NewV : constant Node_Id := New_Copy (Variant); + begin + Set_Discrete_Choices + (NewV, New_Copy_List (Discrete_Choices (Variant))); + Rewrite (Variant, NewV); + end; + end if; + + Expand_Static_Predicates_In_Choices (Variant); + end if; + + -- We don't need to worry about the declarations in the variant + -- (since they were analyzed by Analyze_Choices when we first + -- encountered the variant), but we do need to take care of + -- expansion of any nested variants. + + if not Null_Present (CL) then + VP := Variant_Part (CL); + + if Present (VP) then + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + end if; + end if; + end Process_Declarations; + + -- Start of processing for Check_Variant_Part + + begin + -- Find component list + + C := Empty; + + if Nkind (D) = N_Full_Type_Declaration then + T := Type_Definition (D); + + if Nkind (T) = N_Record_Definition then + C := Component_List (T); + + elsif Nkind (T) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (T)) + then + C := Component_List (Record_Extension_Part (T)); + end if; + end if; + + -- Case of variant part present + + if Present (C) and then Present (Variant_Part (C)) then + VP := Variant_Part (C); + + -- Check choices + + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + + -- If the last variant does not contain the Others choice, + -- replace it with an N_Others_Choice node since Gigi always + -- wants an Others. Note that we do not bother to call Analyze + -- on the modified variant part, since its only effect would be + -- to compute the Others_Discrete_Choices node laboriously, and + -- of course we already know the list of choices corresponding + -- to the others choice (it's the list we're replacing!) + + -- We only want to do this if the expander is active, since + -- we do not want to clobber the ASIS tree! + + if Expander_Active then + declare + Last_Var : constant Node_Id := + Last_Non_Pragma (Variants (VP)); + + Others_Node : Node_Id; + + begin + if Nkind (First (Discrete_Choices (Last_Var))) /= + N_Others_Choice + then + Others_Node := Make_Others_Choice (Sloc (Last_Var)); + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Var)); + Set_Discrete_Choices + (Last_Var, New_List (Others_Node)); + end if; + end; + end if; + end if; + end Check_Variant_Part; + end if; + end Freeze_Entity_Checks; + ------------------------- -- Get_Alignment_Value -- ------------------------- @@ -7957,6 +9515,7 @@ package body Sem_Ch13 is ------------------------------------- procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is + function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item (Rep_Item : Node_Id) return Boolean; -- This routine checks if Rep_Item is either a pragma or an aspect @@ -8044,6 +9603,7 @@ package body Sem_Ch13 is -- Default_Component_Value if Is_Array_Type (Typ) + and then Is_Base_Type (Typ) and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) and then Has_Rep_Item (Typ, Name_Default_Component_Value) then @@ -8055,6 +9615,7 @@ package body Sem_Ch13 is -- Default_Value if Is_Scalar_Type (Typ) + and then Is_Base_Type (Typ) and then Has_Rep_Item (Typ, Name_Default_Value, False) and then Has_Rep_Item (Typ, Name_Default_Value) then @@ -8191,11 +9752,12 @@ package body Sem_Ch13 is begin if Nkind (N) /= N_Attribute_Definition_Clause then return False; + else declare - Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); + Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); begin - return Id = Attribute_Input + return Id = Attribute_Input or else Id = Attribute_Output or else Id = Attribute_Read or else Id = Attribute_Write @@ -8480,10 +10042,11 @@ package body Sem_Ch13 is 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); + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Subp_Id, + Parameter_Specifications => Formals, + Result_Definition => T_Ref); else -- V : [out] T @@ -8591,6 +10154,7 @@ package body Sem_Ch13 is elsif Has_Private_Component (T) then if Nkind (N) = N_Pragma then return False; + else Error_Msg_N ("representation item must appear after type is fully defined", @@ -8625,7 +10189,13 @@ package body Sem_Ch13 is procedure Too_Late is begin - Error_Msg_N ("|representation item appears too late!", N); + -- Other compilers seem more relaxed about rep items appearing too + -- late. Since analysis tools typically don't care about rep items + -- anyway, no reason to be too strict about this. + + if not Relaxed_RM_Semantics then + Error_Msg_N ("|representation item appears too late!", N); + end if; end Too_Late; -- Start of processing for Rep_Item_Too_Late @@ -8638,9 +10208,9 @@ package body Sem_Ch13 is -- 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) + and then not From_Limited_With (T) - -- Exclude generated entitiesa (not coming from source). The common + -- Exclude generated entities (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. @@ -8652,7 +10222,7 @@ package body Sem_Ch13 is if Present (Freeze_Node (S)) then Error_Msg_NE - ("?no more representation items for }", Freeze_Node (S), S); + ("??no more representation items for }", Freeze_Node (S), S); end if; return True; @@ -8685,17 +10255,12 @@ package body Sem_Ch13 is -- but avoid chaining if we have an overloadable entity, and the pragma -- is one that can apply to multiple overloaded entities. - if Is_Overloadable (T) - and then Nkind (N) = N_Pragma - then + if Is_Overloadable (T) and then Nkind (N) = N_Pragma then declare Pname : constant Name_Id := Pragma_Name (N); begin - if Pname = Name_Convention or else - Pname = Name_Import or else - Pname = Name_Export or else - Pname = Name_External or else - Pname = Name_Interface + if Nam_In (Pname, Name_Convention, Name_Import, Name_Export, + Name_External, Name_Interface) then return False; end if; @@ -8848,12 +10413,16 @@ package body Sem_Ch13 is return False; end if; - -- Representations are different if component alignments differ + -- Representations are different if component alignments or scalar + -- storage orders differ. if (Is_Record_Type (T1) or else Is_Array_Type (T1)) - and then + and then (Is_Record_Type (T2) or else Is_Array_Type (T2)) - and then Component_Alignment (T1) /= Component_Alignment (T2) + and then + (Component_Alignment (T1) /= Component_Alignment (T2) + or else + Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) then return False; end if; @@ -8930,7 +10499,7 @@ package body Sem_Ch13 is function Same_Rep return Boolean; -- CD1 and CD2 are either components or discriminants. This - -- function tests whether the two have the same representation + -- function tests whether they have the same representation. -------------- -- Same_Rep -- @@ -8940,8 +10509,11 @@ package body Sem_Ch13 is begin if No (Component_Clause (CD1)) then return No (Component_Clause (CD2)); - else + -- Note: at this point, component clauses have been + -- normalized to the default bit order, so that the + -- comparison of Component_Bit_Offsets is meaningful. + return Present (Component_Clause (CD2)) and then @@ -8955,8 +10527,6 @@ package body Sem_Ch13 is begin if Has_Discriminants (T1) then - CD1 := First_Discriminant (T1); - CD2 := First_Discriminant (T2); -- The number of discriminants may be different if the -- derived type has fewer (constrained by values). The @@ -8964,9 +10534,9 @@ package body Sem_Ch13 is -- the original, so the discrepancy does not per se -- indicate a different representation. - while Present (CD1) - and then Present (CD2) - loop + CD1 := First_Discriminant (T1); + CD2 := First_Discriminant (T2); + while Present (CD1) and then Present (CD2) loop if not Same_Rep then return False; else @@ -8978,7 +10548,6 @@ package body Sem_Ch13 is CD1 := First_Component (Underlying_Type (Base_Type (T1))); CD2 := First_Component (Underlying_Type (Base_Type (T2))); - while Present (CD1) loop if not Same_Rep then return False; @@ -9004,7 +10573,6 @@ package body Sem_Ch13 is begin L1 := First_Literal (T1); L2 := First_Literal (T2); - while Present (L1) loop if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then return False; @@ -9015,7 +10583,6 @@ package body Sem_Ch13 is end loop; return True; - end Enumeration_Case; -- Any other types have the same representation for these purposes @@ -9041,7 +10608,7 @@ package body Sem_Ch13 is if Warn_On_Biased_Representation then Error_Msg_NE - ("?" & Msg & " forces biased representation for&", N, E); + ("?B?" & Msg & " forces biased representation for&", N, E); end if; end if; end Set_Biased; @@ -9129,7 +10696,6 @@ package body Sem_Ch13 is -- Skip processing of this entry if warning already posted if not Address_Warning_Posted (ACCR.N) then - Expr := Original_Node (Expression (ACCR.N)); -- Get alignments @@ -9151,13 +10717,13 @@ package body Sem_Ch13 is Error_Msg_NE ("?& overlays smaller object", ACCR.N, ACCR.X); Error_Msg_N - ("\?program execution may be erroneous", ACCR.N); + ("\??program execution may be erroneous", ACCR.N); Error_Msg_Uint_1 := X_Size; Error_Msg_NE - ("\?size of & is ^", ACCR.N, ACCR.X); + ("\??size of & is ^", ACCR.N, ACCR.X); Error_Msg_Uint_1 := Y_Size; Error_Msg_NE - ("\?size of & is ^", ACCR.N, ACCR.Y); + ("\??size of & is ^", ACCR.N, ACCR.Y); -- Check for inadequate alignment, both of the base object -- and of the offset, if any. @@ -9178,24 +10744,20 @@ package body Sem_Ch13 is /= Known_Compatible)) then Error_Msg_NE - ("?specified address for& may be inconsistent " - & "with alignment", - ACCR.N, ACCR.X); + ("??specified address for& may be inconsistent " + & "with alignment", ACCR.N, ACCR.X); Error_Msg_N - ("\?program execution may be erroneous (RM 13.3(27))", + ("\??program execution may be erroneous (RM 13.3(27))", ACCR.N); Error_Msg_Uint_1 := X_Alignment; Error_Msg_NE - ("\?alignment of & is ^", - ACCR.N, ACCR.X); + ("\??alignment of & is ^", ACCR.N, ACCR.X); Error_Msg_Uint_1 := Y_Alignment; Error_Msg_NE - ("\?alignment of & is ^", - ACCR.N, ACCR.Y); + ("\??alignment of & is ^", ACCR.N, ACCR.Y); if Y_Alignment >= X_Alignment then Error_Msg_N - ("\?but offset is not multiple of alignment", - ACCR.N); + ("\??but offset is not multiple of alignment", ACCR.N); end if; end if; end if; @@ -9263,9 +10825,8 @@ package body Sem_Ch13 is -- Bad component size, check reason if Has_Component_Size_Clause (Atyp) then - P := - Get_Attribute_Definition_Clause - (Atyp, Attribute_Component_Size); + P := Get_Attribute_Definition_Clause + (Atyp, Attribute_Component_Size); if Present (P) then Error_Msg_Sloc := Sloc (P); @@ -9301,8 +10862,7 @@ package body Sem_Ch13 is procedure No_Independence is begin if Pragma_Name (N) = Name_Independent then - Error_Msg_NE - ("independence cannot be guaranteed for&", N, E); + Error_Msg_NE ("independence cannot be guaranteed for&", N, E); else Error_Msg_NE ("independent components cannot be guaranteed for&", N, E); @@ -9337,7 +10897,8 @@ package body Sem_Ch13 is -- cases where we cannot check static values. if not (Known_Static_Esize (C) - and then Known_Static_Esize (Ctyp)) + and then + Known_Static_Esize (Ctyp)) then return False; end if; @@ -9345,9 +10906,7 @@ package body Sem_Ch13 is -- Size of component must be addressable or greater than 64 bits -- and a multiple of bytes. - if not Addressable (Esize (C)) - and then Esize (C) < Uint_64 - then + if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then return False; end if; @@ -9536,9 +11095,7 @@ package body Sem_Ch13 is -- Source may be unconstrained array, but not target - if Is_Array_Type (Target) - and then not Is_Constrained (Target) - then + if Is_Array_Type (Target) and then not Is_Constrained (Target) then Error_Msg_N ("unchecked conversion to unconstrained array not allowed", N); return; @@ -9560,7 +11117,8 @@ package body Sem_Ch13 is or else OpenVMS_On_Target then Error_Msg_N - ("?conversion between pointers with different conventions!", N); + ("?z?conversion between pointers with different conventions!", + N); end if; end if; @@ -9584,11 +11142,9 @@ package body Sem_Ch13 is begin pragma Assert (Present (Calendar_Time)); - if Source = Calendar_Time - or else Target = Calendar_Time - then + if Source = Calendar_Time or else Target = Calendar_Time then Error_Msg_N - ("?representation of 'Time values may change between " & + ("?z?representation of 'Time values may change between " & "'G'N'A'T versions", N); end if; end; @@ -9601,17 +11157,17 @@ package body Sem_Ch13 is if Warn_On_Unchecked_Conversion then Unchecked_Conversions.Append - (New_Val => UC_Entry' - (Eloc => Sloc (N), - Source => Source, - Target => Target)); + (New_Val => UC_Entry'(Eloc => Sloc (N), + Source => Source, + Target => Target)); -- If both sizes are known statically now, then back end annotation -- is not required to do a proper check but if either size is not -- known statically, then we need the annotation. if Known_Static_RM_Size (Source) - and then Known_Static_RM_Size (Target) + and then + Known_Static_RM_Size (Target) then null; else @@ -9689,7 +11245,7 @@ package body Sem_Ch13 is if Source_Siz /= Target_Siz then Error_Msg - ("?types for unchecked conversion have different sizes!", + ("?z?types for unchecked conversion have different sizes!", Eloc); if All_Errors_Mode then @@ -9697,53 +11253,51 @@ package body Sem_Ch13 is Error_Msg_Uint_1 := Source_Siz; Error_Msg_Name_2 := Chars (Target); Error_Msg_Uint_2 := Target_Siz; - Error_Msg ("\size of % is ^, size of % is ^?", Eloc); + Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc); Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); if Is_Discrete_Type (Source) - and then Is_Discrete_Type (Target) + and then + Is_Discrete_Type (Target) then if Source_Siz > Target_Siz then Error_Msg - ("\?^ high order bits of source will be ignored!", - Eloc); + ("\?z?^ high order bits of source will " + & "be ignored!", Eloc); elsif Is_Unsigned_Type (Source) then Error_Msg - ("\?source will be extended with ^ high order " & - "zero bits?!", Eloc); + ("\?z?source will be extended with ^ high order " + & "zero bits?!", Eloc); else Error_Msg - ("\?source will be extended with ^ high order " & - "sign bits!", - Eloc); + ("\?z?source will be extended with ^ high order " + & "sign bits!", Eloc); end if; elsif Source_Siz < Target_Siz then if Is_Discrete_Type (Target) then if Bytes_Big_Endian then Error_Msg - ("\?target value will include ^ undefined " & - "low order bits!", - Eloc); + ("\?z?target value will include ^ undefined " + & "low order bits!", Eloc); else Error_Msg - ("\?target value will include ^ undefined " & - "high order bits!", - Eloc); + ("\?z?target value will include ^ undefined " + & "high order bits!", Eloc); end if; else Error_Msg - ("\?^ trailing bits of target value will be " & - "undefined!", Eloc); + ("\?z?^ trailing bits of target value will be " + & "undefined!", Eloc); end if; else pragma Assert (Source_Siz > Target_Siz); Error_Msg - ("\?^ trailing bits of source will be ignored!", + ("\?z?^ trailing bits of source will be ignored!", Eloc); end if; end if; @@ -9766,7 +11320,8 @@ package body Sem_Ch13 is begin if Known_Alignment (D_Source) - and then Known_Alignment (D_Target) + and then + Known_Alignment (D_Target) then declare Source_Align : constant Uint := Alignment (D_Source); @@ -9795,11 +11350,11 @@ package body Sem_Ch13 is Error_Msg_Node_1 := D_Target; Error_Msg_Node_2 := D_Source; Error_Msg - ("?alignment of & (^) is stricter than " & - "alignment of & (^)!", Eloc); + ("?z?alignment of & (^) is stricter than " + & "alignment of & (^)!", Eloc); Error_Msg - ("\?resulting access value may have invalid " & - "alignment!", Eloc); + ("\?z?resulting access value may have invalid " + & "alignment!", Eloc); end if; end; end if;