From 5a8a6763b58fe46c1a2f1710b31705565e29667c Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Thu, 10 Oct 2013 12:46:01 +0000 Subject: [PATCH] freeze.adb: Minor reformatting. 2013-10-10 Robert Dewar * freeze.adb: Minor reformatting. * sem_ch13.adb (Freeze_Entity_Checks): New procedure (Analyze_Freeze_Entity): Call Freeze_Entity_Checks (Analyze_Freeze_Generic_Entity): Call Freeze_Entity_Checks. * sinfo.ads: Add syntax for sprint for Freeze_Generic_Entity. * sprint.ads: Add syntax for freeze generic entity node. 2013-10-10 Robert Dewar * einfo.adb, einfo.ads: Minor comment updates. From-SVN: r203368 --- gcc/ada/ChangeLog | 13 + gcc/ada/einfo.adb | 4 - gcc/ada/einfo.ads | 10 +- gcc/ada/freeze.adb | 10 +- gcc/ada/sem_ch13.adb | 4551 +++++++++++++++++++++++++------------------------- gcc/ada/sinfo.ads | 2 + gcc/ada/sprint.ads | 3 +- 7 files changed, 2320 insertions(+), 2273 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5377a51..179607d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,18 @@ 2013-10-10 Robert Dewar + * freeze.adb: Minor reformatting. + * sem_ch13.adb (Freeze_Entity_Checks): New procedure + (Analyze_Freeze_Entity): Call Freeze_Entity_Checks + (Analyze_Freeze_Generic_Entity): Call Freeze_Entity_Checks. + * sinfo.ads: Add syntax for sprint for Freeze_Generic_Entity. + * sprint.ads: Add syntax for freeze generic entity node. + +2013-10-10 Robert Dewar + + * einfo.adb, einfo.ads: Minor comment updates. + +2013-10-10 Robert Dewar + * lib-writ.adb (Write_Unit_Information): Fatal error if linker options are detected in a predefined generic unit. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index fb53f1b..f467144 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -9017,10 +9017,6 @@ package body Einfo is Generic_Subprogram_Kind => Write_Str ("Contract"); - -- The Subprogram_Kind and Generic_Subrpogram_Kind entries - -- here are odd, since the assertions for [Set_]Contract do not - -- allow these possibilities ??? - when others => Write_Str ("Field24???"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b06026b..02626f5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1022,9 +1022,9 @@ package Einfo is -- 'COUNT when it applies to a family member. -- Contract (Node24) --- Defined in entries, and in subprogram and generic subprogram entities. --- Points to the contract of the entity, holding both pre- and --- postconditions as well as test-cases. +-- Defined in entry and entry family entities, subprogram body entities, +-- subprograms, and generic subprograms. Points to the contract of the +-- entity, holding both preconditions, postconditions, and test cases. -- Entry_Parameters_Type (Node15) -- Defined in entries. Points to the access-to-record type that is @@ -5306,7 +5306,7 @@ package Einfo is -- Accept_Address (Elist21) -- Scope_Depth_Value (Uint22) -- Protection_Object (Node23) (protected kind) - -- Contract (Node24) (for entry only) + -- Contract (Node24) -- PPC_Wrapper (Node25) -- Extra_Formals (Node28) -- Default_Expressions_Processed (Flag108) @@ -5567,6 +5567,7 @@ package Einfo is -- Alias (Node18) -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) + -- Contract (Node24) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) -- Has_Invariants (Flag232) @@ -5863,6 +5864,7 @@ package Einfo is -- Corresponding_Protected_Entry (Node18) -- Last_Entity (Node20) -- Scope_Depth_Value (Uint22) + -- Contract (Node24) -- Extra_Formals (Node28) -- SPARK_Mode_Pragmas (Node32) -- Scope_Depth (synth) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 68f400d..67f203d 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1953,8 +1953,8 @@ package body Freeze is ----------------------------- function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is - E : Entity_Id; - F : Node_Id; + E : Entity_Id; + F : Node_Id; Flist : List_Id; begin @@ -2793,6 +2793,12 @@ package body Freeze is then return No_List; + -- Generic types need no freeze node and have no delayed semantic + -- checks. + + elsif Is_Generic_Type (E) then + return No_List; + -- Do not freeze a global entity within an inner scope created during -- expansion. A call to subprogram E within some internal procedure -- (a stream attribute for example) might require freezing E, but the diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 0f6ea38..d96c5bc 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -112,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 @@ -5072,656 +5079,310 @@ package body Sem_Ch13 is --------------------------- 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). + Freeze_Entity_Checks (N); + end Analyze_Freeze_Entity; - Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + ----------------------------------- + -- Analyze_Freeze_Generic_Entity -- + ----------------------------------- - -- 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). + procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is + begin + Freeze_Entity_Checks (N); + end Analyze_Freeze_Generic_Entity; - 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. + ------------------------------------------ + -- Analyze_Record_Representation_Clause -- + ------------------------------------------ - Add_Internal_Interface_Entities (E); - end if; + -- Note: we check as much as we can here, but we can't do any checks + -- based on the position values (e.g. overlap checks) until freeze time + -- because especially in Ada 2005 (machine scalar mode), the processing + -- for non-standard bit order can substantially change the positions. + -- See procedure Check_Record_Representation_Clause (called from Freeze) + -- for the remainder of this processing. - -- Check CPP types + procedure Analyze_Record_Representation_Clause (N : Node_Id) is + Ident : constant Node_Id := Identifier (N); + Biased : Boolean; + CC : Node_Id; + Comp : Entity_Id; + Fbit : Uint; + Hbit : Uint := Uint_0; + Lbit : Uint; + Ocomp : Entity_Id; + Posit : Uint; + Rectype : Entity_Id; + Recdef : Node_Id; - 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 + function Is_Inherited (Comp : Entity_Id) return Boolean; + -- True if Comp is an inherited component in a record extension - -- 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. + ------------------ + -- Is_Inherited -- + ------------------ - pragma Assert (Chars (First_Entity (E)) = Name_uTag); + function Is_Inherited (Comp : Entity_Id) return Boolean is + Comp_Base : Entity_Id; - 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; + begin + if Ekind (Rectype) = E_Record_Subtype then + Comp_Base := Original_Record_Component (Comp); + else + Comp_Base := Comp; 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; + return Comp_Base /= Original_Record_Component (Comp_Base); + end Is_Inherited; - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); + -- Local variables - if Comes_From_Source (Prim) then - if Is_Abstract_Subprogram (Prim) then - null; + Is_Record_Extension : Boolean; + -- True if Rectype is a record extension - 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); + CR_Pragma : Node_Id := Empty; + -- Points to N_Pragma node if Complete_Representation pragma present - 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; + -- Start of processing for Analyze_Record_Representation_Clause - Next_Elmt (Elmt); - end loop; - end; + begin + if Ignore_Rep_Clauses then + return; 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. + Find_Type (Ident); + Rectype := Entity (Ident); - declare - Elmt : Elmt_Id; - Prim : Node_Id; + if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then + return; + else + Rectype := Underlying_Type (Rectype); + end if; - begin - Elmt := First_Elmt (Primitive_Operations (E)); - while Present (Elmt) loop - Prim := Node (Elmt); + -- First some basic error checks - 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; + if not Is_Record_Type (Rectype) then + Error_Msg_NE + ("record type required, found}", Ident, First_Subtype (Rectype)); + return; - Next_Elmt (Elmt); - end loop; - end; - end if; + elsif Scope (Rectype) /= Current_Scope then + Error_Msg_N ("type must be declared in this scope", N); + return; - Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + elsif not Is_First_Subtype (Rectype) then + Error_Msg_N ("cannot give record rep clause for subtype", N); + return; - -- If we have a type with predicates, build predicate function + elsif Has_Record_Rep_Clause (Rectype) then + Error_Msg_N ("duplicate record rep clause ignored", N); + return; - if Is_Type (E) and then Has_Predicates (E) then - Build_Predicate_Functions (E, N); + elsif Rep_Item_Too_Late (Rectype, N) then + return; 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. - - 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. + -- We know we have a first subtype, now possibly go the the anonymous + -- base type to determine whether Rectype is a record extension. - Push_Scope_And_Install_Discriminants (E); + 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 - Ritem : Node_Id; + Loc : constant Source_Ptr := Sloc (N); + M : constant Node_Id := Mod_Clause (N); + P : constant List_Id := Pragmas_Before (M); + AtM_Nod : Node_Id; + + Mod_Val : Uint; + pragma Warnings (Off, Mod_Val); begin - -- Look for aspect specification entries for this entity + Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); - 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; + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("?j?mod clause is an obsolescent feature (RM J.8)", N); + Error_Msg_N + ("\?j?use alignment attribute definition clause instead", N); + end if; - Next_Rep_Item (Ritem); - end loop; - end; + if Present (P) then + Analyze_List (P); + end if; - Uninstall_Discriminants_And_Pop_Scope (E); - end if; + -- In ASIS_Mode mode, expansion is disabled, but we must convert + -- the Mod clause into an alignment clause anyway, so that the + -- back-end can compute and back-annotate properly the size and + -- alignment of types that may include this record. - -- 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. + -- This seems dubious, this destroys the source tree in a manner + -- not detectable by ASIS ??? - 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; + if Operating_Mode = Check_Semantics and then ASIS_Mode then + AtM_Nod := + Make_Attribute_Definition_Clause (Loc, + Name => New_Reference_To (Base_Type (Rectype), Loc), + Chars => Name_Alignment, + Expression => Relocate_Node (Expression (M))); - Others_Present : Boolean; - pragma Warnings (Off, Others_Present); - -- Indicates others present, not used in this case + Set_From_At_Mod (AtM_Nod); + Insert_After (N, AtM_Nod); + Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); + Set_Mod_Clause (N, Empty); - 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. + else + -- Get the alignment value to perform error checking - 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. + Mod_Val := Get_Alignment_Value (Expression (M)); + end if; + end; + end if; - 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; + -- For untagged types, clear any existing component clauses for the + -- type. If the type is derived, this is what allows us to override + -- a rep clause for the parent. For type extensions, the representation + -- of the inherited components is inherited, so we want to keep previous + -- component clauses for completeness. - ----------------------------- - -- Non_Static_Choice_Error -- - ----------------------------- + if not Is_Tagged_Type (Rectype) then + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + Set_Component_Clause (Comp, Empty); + Next_Component_Or_Discriminant (Comp); + end loop; + end if; - 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; + -- All done if no component clauses - -------------------------- - -- Process_Declarations -- - -------------------------- + CC := First (Component_Clauses (N)); - procedure Process_Declarations (Variant : Node_Id) is - CL : constant Node_Id := Component_List (Variant); - VP : Node_Id; + if No (CC) then + return; + end if; - begin - -- Check for static predicate present in this variant + -- A representation like this applies to the base type - if Has_SP_Choice (Variant) then + Set_Has_Record_Rep_Clause (Base_Type (Rectype)); + Set_Has_Non_Standard_Rep (Base_Type (Rectype)); + Set_Has_Specified_Layout (Base_Type (Rectype)); - -- 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. + -- Process the component clauses - -- 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. + while Present (CC) loop - -- 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. + -- Pragma - 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; + if Nkind (CC) = N_Pragma then + Analyze (CC); - Expand_Static_Predicates_In_Choices (Variant); - end if; + -- The only pragma of interest is Complete_Representation - -- 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 Pragma_Name (CC) = Name_Complete_Representation then + CR_Pragma := CC; + end if; - if not Null_Present (CL) then - VP := Variant_Part (CL); + -- Processing for real component clause - if Present (VP) then - Check_Choices - (VP, Variants (VP), Etype (Name (VP)), Others_Present); - end if; - end if; - end Process_Declarations; + else + Posit := Static_Integer (Position (CC)); + Fbit := Static_Integer (First_Bit (CC)); + Lbit := Static_Integer (Last_Bit (CC)); - -- Start of processing for Check_Variant_Part + if Posit /= No_Uint + and then Fbit /= No_Uint + and then Lbit /= No_Uint + then + if Posit < 0 then + Error_Msg_N + ("position cannot be negative", Position (CC)); - begin - -- Find component list + elsif Fbit < 0 then + Error_Msg_N + ("first bit cannot be negative", First_Bit (CC)); - C := Empty; + -- The Last_Bit specified in a component clause must not be + -- less than the First_Bit minus one (RM-13.5.1(10)). - if Nkind (D) = N_Full_Type_Declaration then - T := Type_Definition (D); + elsif Lbit < Fbit - 1 then + Error_Msg_N + ("last bit cannot be less than first bit minus one", + Last_Bit (CC)); - if Nkind (T) = N_Record_Definition then - C := Component_List (T); + -- Values look OK, so find the corresponding record component + -- Even though the syntax allows an attribute reference for + -- implementation-defined components, GNAT does not allow the + -- tag to get an explicit position. - 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; + elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then + if Attribute_Name (Component_Name (CC)) = Name_Tag then + Error_Msg_N ("position of tag cannot be specified", CC); + else + Error_Msg_N ("illegal component name", CC); + end if; - -- Case of variant part present + else + Comp := First_Entity (Rectype); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; - if Present (C) and then Present (Variant_Part (C)) then - VP := Variant_Part (C); + if No (Comp) then - -- Check choices + -- Maybe component of base type that is absent from + -- statically constrained first subtype. - Check_Choices - (VP, Variants (VP), Etype (Name (VP)), Others_Present); + Comp := First_Entity (Base_Type (Rectype)); + while Present (Comp) loop + exit when Chars (Comp) = Chars (Component_Name (CC)); + Next_Entity (Comp); + end loop; + end if; - -- 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!) + if No (Comp) then + Error_Msg_N + ("component clause is for non-existent field", CC); - -- We only want to do this if the expander is active, since - -- we do not want to clobber the ASIS tree! + -- Ada 2012 (AI05-0026): Any name that denotes a + -- discriminant of an object of an unchecked union type + -- shall not occur within a record_representation_clause. - if Expander_Active then - declare - Last_Var : constant Node_Id := - Last_Non_Pragma (Variants (VP)); + -- The general restriction of using record rep clauses on + -- Unchecked_Union types has now been lifted. Since it is + -- possible to introduce a record rep clause which mentions + -- the discriminant of an Unchecked_Union in non-Ada 2012 + -- code, this check is applied to all versions of the + -- language. - Others_Node : Node_Id; + elsif Ekind (Comp) = E_Discriminant + and then Is_Unchecked_Union (Rectype) + then + Error_Msg_N + ("cannot reference discriminant of unchecked union", + Component_Name (CC)); - 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 Analyze_Freeze_Entity; + elsif Is_Record_Extension and then Is_Inherited (Comp) then + Error_Msg_NE + ("component clause not allowed for inherited " + & "component&", CC, Comp); - ----------------------------------- - -- Analyze_Freeze_Generic_Entity -- - ----------------------------------- + elsif Present (Component_Clause (Comp)) then - procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is - begin - -- Semantic checks here - null; - end Analyze_Freeze_Generic_Entity; + -- Diagnose duplicate rep clause, or check consistency + -- if this is an inherited component. In a double fault, + -- there may be a duplicate inconsistent clause for an + -- inherited component. - ------------------------------------------ - -- Analyze_Record_Representation_Clause -- - ------------------------------------------ - - -- Note: we check as much as we can here, but we can't do any checks - -- based on the position values (e.g. overlap checks) until freeze time - -- because especially in Ada 2005 (machine scalar mode), the processing - -- for non-standard bit order can substantially change the positions. - -- See procedure Check_Record_Representation_Clause (called from Freeze) - -- for the remainder of this processing. - - procedure Analyze_Record_Representation_Clause (N : Node_Id) is - Ident : constant Node_Id := Identifier (N); - Biased : Boolean; - CC : Node_Id; - Comp : Entity_Id; - Fbit : Uint; - Hbit : Uint := Uint_0; - Lbit : Uint; - 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; - end if; - - Find_Type (Ident); - Rectype := Entity (Ident); - - if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then - return; - else - Rectype := Underlying_Type (Rectype); - end if; - - -- First some basic error checks - - if not Is_Record_Type (Rectype) then - Error_Msg_NE - ("record type required, found}", Ident, First_Subtype (Rectype)); - return; - - elsif Scope (Rectype) /= Current_Scope then - Error_Msg_N ("type must be declared in this scope", N); - return; - - elsif not Is_First_Subtype (Rectype) then - Error_Msg_N ("cannot give record rep clause for subtype", N); - return; - - elsif Has_Record_Rep_Clause (Rectype) then - Error_Msg_N ("duplicate record rep clause ignored", N); - return; - - elsif Rep_Item_Too_Late (Rectype, N) then - 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); - M : constant Node_Id := Mod_Clause (N); - P : constant List_Id := Pragmas_Before (M); - AtM_Nod : Node_Id; - - Mod_Val : Uint; - pragma Warnings (Off, Mod_Val); - - begin - Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); - - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("?j?mod clause is an obsolescent feature (RM J.8)", N); - Error_Msg_N - ("\?j?use alignment attribute definition clause instead", N); - end if; - - if Present (P) then - Analyze_List (P); - end if; - - -- In ASIS_Mode mode, expansion is disabled, but we must convert - -- the Mod clause into an alignment clause anyway, so that the - -- back-end can compute and back-annotate properly the size and - -- alignment of types that may include this record. - - -- This seems dubious, this destroys the source tree in a manner - -- not detectable by ASIS ??? - - if Operating_Mode = Check_Semantics and then ASIS_Mode then - AtM_Nod := - Make_Attribute_Definition_Clause (Loc, - Name => New_Reference_To (Base_Type (Rectype), Loc), - Chars => Name_Alignment, - Expression => Relocate_Node (Expression (M))); - - Set_From_At_Mod (AtM_Nod); - Insert_After (N, AtM_Nod); - Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); - Set_Mod_Clause (N, Empty); - - else - -- Get the alignment value to perform error checking - - Mod_Val := Get_Alignment_Value (Expression (M)); - end if; - end; - end if; - - -- For untagged types, clear any existing component clauses for the - -- type. If the type is derived, this is what allows us to override - -- a rep clause for the parent. For type extensions, the representation - -- of the inherited components is inherited, so we want to keep previous - -- component clauses for completeness. - - if not Is_Tagged_Type (Rectype) then - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - Set_Component_Clause (Comp, Empty); - Next_Component_Or_Discriminant (Comp); - end loop; - end if; - - -- All done if no component clauses - - CC := First (Component_Clauses (N)); - - if No (CC) then - return; - end if; - - -- A representation like this applies to the base type - - Set_Has_Record_Rep_Clause (Base_Type (Rectype)); - Set_Has_Non_Standard_Rep (Base_Type (Rectype)); - Set_Has_Specified_Layout (Base_Type (Rectype)); - - -- Process the component clauses - - while Present (CC) loop - - -- Pragma - - if Nkind (CC) = N_Pragma then - Analyze (CC); - - -- The only pragma of interest is Complete_Representation - - if Pragma_Name (CC) = Name_Complete_Representation then - CR_Pragma := CC; - end if; - - -- Processing for real component clause - - else - Posit := Static_Integer (Position (CC)); - Fbit := Static_Integer (First_Bit (CC)); - Lbit := Static_Integer (Last_Bit (CC)); - - if Posit /= No_Uint - and then Fbit /= No_Uint - and then Lbit /= No_Uint - then - if Posit < 0 then - Error_Msg_N - ("position cannot be negative", Position (CC)); - - elsif Fbit < 0 then - Error_Msg_N - ("first bit cannot be negative", First_Bit (CC)); - - -- The Last_Bit specified in a component clause must not be - -- less than the First_Bit minus one (RM-13.5.1(10)). - - elsif Lbit < Fbit - 1 then - Error_Msg_N - ("last bit cannot be less than first bit minus one", - Last_Bit (CC)); - - -- Values look OK, so find the corresponding record component - -- Even though the syntax allows an attribute reference for - -- implementation-defined components, GNAT does not allow the - -- tag to get an explicit position. - - elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then - if Attribute_Name (Component_Name (CC)) = Name_Tag then - Error_Msg_N ("position of tag cannot be specified", CC); - else - Error_Msg_N ("illegal component name", CC); - end if; - - else - Comp := First_Entity (Rectype); - while Present (Comp) loop - exit when Chars (Comp) = Chars (Component_Name (CC)); - Next_Entity (Comp); - end loop; - - if No (Comp) then - - -- Maybe component of base type that is absent from - -- statically constrained first subtype. - - Comp := First_Entity (Base_Type (Rectype)); - while Present (Comp) loop - exit when Chars (Comp) = Chars (Component_Name (CC)); - Next_Entity (Comp); - end loop; - end if; - - if No (Comp) then - Error_Msg_N - ("component clause is for non-existent field", CC); - - -- Ada 2012 (AI05-0026): Any name that denotes a - -- discriminant of an object of an unchecked union type - -- shall not occur within a record_representation_clause. - - -- The general restriction of using record rep clauses on - -- Unchecked_Union types has now been lifted. Since it is - -- possible to introduce a record rep clause which mentions - -- the discriminant of an Unchecked_Union in non-Ada 2012 - -- code, this check is applied to all versions of the - -- language. - - elsif Ekind (Comp) = E_Discriminant - and then Is_Unchecked_Union (Rectype) - then - Error_Msg_N - ("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 - -- if this is an inherited component. In a double fault, - -- there may be a duplicate inconsistent clause for an - -- inherited component. - - if Scope (Original_Record_Component (Comp)) = Rectype - or else Parent (Component_Clause (Comp)) = N - then - Error_Msg_Sloc := Sloc (Component_Clause (Comp)); - Error_Msg_N ("component clause previously given#", CC); + if Scope (Original_Record_Component (Comp)) = Rectype + or else Parent (Component_Clause (Comp)) = N + then + Error_Msg_Sloc := Sloc (Component_Clause (Comp)); + Error_Msg_N ("component clause previously given#", CC); else declare @@ -6945,32 +6606,166 @@ package body Sem_Ch13 is -- the expression (i.e. if it is an identifier whose Chars field matches -- the Nam given in the call). - function Lo_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value or low bound of range. + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value or low bound of range. + + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value of high bound of range. + + function Membership_Entry (N : Node_Id) return RList; + -- Given a single membership entry (range, value, or subtype), returns + -- the corresponding range list. Raises Static_Error if not static. + + function Membership_Entries (N : Node_Id) return RList; + -- Given an element on an alternatives list of a membership operation, + -- returns the range list corresponding to this entry and all following + -- entries (i.e. returns the "or" of this list of values). + + function Stat_Pred (Typ : Entity_Id) return RList; + -- Given a type, if it has a static predicate, then return the predicate + -- as a range list, otherwise raise Non_Static. + + ----------- + -- "and" -- + ----------- + + function "and" (Left : RList; Right : RList) return RList is + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- If either range is True, return the other + + if Is_True (Left) then + return Right; + elsif Is_True (Right) then + return Left; + end if; + + -- If either range is False, return False + + if Is_False (Left) or else Is_False (Right) then + return False_Range; + end if; + + -- 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 + + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; + + -- Discard first left operand entry if disjoint with right + + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; + + -- Discard first right operand entry if disjoint with left + + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; + + -- Otherwise we have an overlapping entry + + else + exit; + 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. + + 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. + + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + 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. + + return + FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : RList) return RList is + begin + -- Return True if False range + + if Is_False (Right) then + return True_Range; + end if; + + -- Return False if True range + + if Is_True (Right) then + return False_Range; + end if; + + -- Here if not trivial case + + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end + + Count : Nat := 0; + -- Number of entries stored in Result + + begin + -- Gap at start + + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; + + -- Gaps between ranges - function Hi_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value of high bound of range. + for J in Right'First .. Right'Last - 1 loop + Count := Count + 1; + Result (Count) := + REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); + end loop; - function Membership_Entry (N : Node_Id) return RList; - -- Given a single membership entry (range, value, or subtype), returns - -- the corresponding range list. Raises Static_Error if not static. + -- Gap at end - function Membership_Entries (N : Node_Id) return RList; - -- Given an element on an alternatives list of a membership operation, - -- returns the range list corresponding to this entry and all following - -- entries (i.e. returns the "or" of this list of values). + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; - function Stat_Pred (Typ : Entity_Id) return RList; - -- Given a type, if it has a static predicate, then return the predicate - -- as a range list, otherwise raise Non_Static. + return Result (1 .. Count); + end; + end "not"; - ----------- - -- "and" -- - ----------- + ---------- + -- "or" -- + ---------- - function "and" (Left : RList; Right : RList) return RList is + function "or" (Left : RList; Right : RList) return RList is FEnt : REnt; -- First range of result @@ -6981,2227 +6776,2459 @@ package body Sem_Ch13 is -- Start of rest of right entries begin - -- If either range is True, return the other + -- If either range is True, return True - if Is_True (Left) then + if Is_True (Left) or else Is_True (Right) then + return True_Range; + end if; + + -- If either range is False (empty), return the other + + if Is_False (Left) then return Right; - elsif Is_True (Right) then + elsif Is_False (Right) then return Left; end if; - -- If either range is False, return False + -- Initialize result first entry from left or right operand depending + -- on which starts with the lower range. - if Is_False (Left) or else Is_False (Right) then - return False_Range; + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; end if; - -- Loop to remove entries at start that are disjoint, and thus just - -- get discarded from the result entirely. + -- This loop eats ranges from left and right operands that are + -- contiguous with the first range we are gathering. loop - -- If no operands left in either operand, result is false - - if SLeft > Left'Last or else SRight > Right'Last then - return False_Range; - - -- Discard first left operand entry if disjoint with right + -- Eat first entry in left operand if contiguous or overlapped by + -- gathered first operand of result. - elsif Left (SLeft).Hi < Right (SRight).Lo then + if SLeft <= Left'Last + and then Left (SLeft).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); SLeft := SLeft + 1; - -- Discard first right operand entry if disjoint with left + -- Eat first entry in right operand if contiguous or overlapped by + -- gathered right operand of result. - elsif Right (SRight).Hi < Left (SLeft).Lo then + elsif SRight <= Right'Last + and then Right (SRight).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); SRight := SRight + 1; - -- Otherwise we have an overlapping entry + -- All done if no more entries to eat else exit; 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. + -- Obtain result as the first entry we just computed, concatenated + -- to the "or" of the remaining results (if one operand is empty, + -- this will just concatenate with the other - FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), - Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); + return + FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end "or"; - -- Now we can remove the entry that ended at a lower value, since its - -- contribution is entirely contained in Fent. + ----------------- + -- Build_Range -- + ----------------- - if Left (SLeft).Hi <= Right (SRight).Hi then - SLeft := SLeft + 1; + function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is + Result : Node_Id; + + begin + 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; + + --------------- + -- Build_Val -- + --------------- + + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; + + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); else - SRight := SRight + 1; + Result := Make_Integer_Literal (Loc, V); 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. + Set_Etype (Result, Btyp); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; - return - FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); - end "and"; + --------------- + -- Get_RList -- + --------------- + + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; + + begin + -- Static expression can only be true or false + + if Is_OK_Static_Expression (Exp) then + + -- For False + + if Expr_Value (Exp) = 0 then + return False_Range; + else + return True_Range; + end if; + end if; + + -- Otherwise test node type + + Op := Nkind (Exp); + + case Op is + + -- And + + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); + + -- Or + + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); + + -- Not + + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); + + -- Comparisons of type with static value + + when N_Op_Compare => + + -- Type is left operand + + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); + + -- Typ is right operand + + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); + + -- Invert sense of comparison + + case Op is + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Ge; + when others => null; + end case; + + -- Other cases are non-static + + else + raise Non_Static; + end if; + + -- Construct range according to comparison operation + + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); + + when N_Op_Ge => + return RList'(1 => REnt'(Val, BHi)); + + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, BHi)); + + when N_Op_Le => + return RList'(1 => REnt'(BLo, Val)); + + when N_Op_Lt => + return RList'(1 => REnt'(BLo, Val - 1)); + + when N_Op_Ne => + return RList'(REnt'(BLo, Val - 1), + REnt'(Val + 1, BHi)); + + when others => + raise Program_Error; + end case; + + -- Membership (IN) + + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - ----------- - -- "not" -- - ----------- + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; - function "not" (Right : RList) return RList is - begin - -- Return True if False range + -- Negative membership (NOT IN) - if Is_False (Right) then - return True_Range; - end if; + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - -- Return False if True range + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; - if Is_True (Right) then - return False_Range; - end if; + -- Function call, may be call to static predicate - -- Here if not trivial case + when N_Function_Call => + if Is_Entity_Name (Name (Exp)) then + declare + Ent : constant Entity_Id := Entity (Name (Exp)); + begin + if Is_Predicate_Function (Ent) + or else + Is_Predicate_Function_M (Ent) + then + return Stat_Pred (Etype (First_Formal (Ent))); + end if; + end; + end if; - declare - Result : RList (1 .. Right'Length + 1); - -- May need one more entry for gap at beginning and end + -- Other function call cases are non-static - Count : Nat := 0; - -- Number of entries stored in Result + raise Non_Static; - begin - -- Gap at start + -- Qualified expression, dig out the expression - if Right (Right'First).Lo > TLo then - Count := Count + 1; - Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); - end if; + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); - -- Gaps between ranges + -- Xor operator - for J in Right'First .. Right'Last - 1 loop - Count := Count + 1; - Result (Count) := - REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); - end loop; + when N_Op_Xor => + return (Get_RList (Left_Opnd (Exp)) + and not Get_RList (Right_Opnd (Exp))) + or (Get_RList (Right_Opnd (Exp)) + and not Get_RList (Left_Opnd (Exp))); - -- Gap at end + -- Any other node type is non-static - if Right (Right'Last).Hi < THi then - Count := Count + 1; - Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); - end if; + when others => + raise Non_Static; + end case; + end Get_RList; - return Result (1 .. Count); - end; - end "not"; + ------------ + -- Hi_Val -- + ------------ - ---------- - -- "or" -- - ---------- + function Hi_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (High_Bound (N)); + end if; + end Hi_Val; - function "or" (Left : RList; Right : RList) return RList is - FEnt : REnt; - -- First range of result + -------------- + -- Is_False -- + -------------- - SLeft : Nat := Left'First; - -- Start of rest of left entries + function Is_False (R : RList) return Boolean is + begin + return R'Length = 0; + end Is_False; - SRight : Nat := Right'First; - -- Start of rest of right entries + ------------- + -- Is_True -- + ------------- + function Is_True (R : RList) return Boolean is begin - -- If either range is True, return True + return R'Length = 1 + and then R (R'First).Lo = BLo + and then R (R'First).Hi = BHi; + end Is_True; - if Is_True (Left) or else Is_True (Right) then - return True_Range; - end if; + ----------------- + -- Is_Type_Ref -- + ----------------- - -- If either range is False (empty), return the other + function Is_Type_Ref (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Identifier and then Chars (N) = Nam; + end Is_Type_Ref; - if Is_False (Left) then - return Right; - elsif Is_False (Right) then - return Left; + ------------ + -- Lo_Val -- + ------------ + + function Lo_Val (N : Node_Id) return Uint is + begin + if Is_Static_Expression (N) then + return Expr_Value (N); + else + pragma Assert (Nkind (N) = N_Range); + return Expr_Value (Low_Bound (N)); end if; + end Lo_Val; - -- Initialize result first entry from left or right operand depending - -- on which starts with the lower range. + ------------------------ + -- Membership_Entries -- + ------------------------ - if Left (SLeft).Lo < Right (SRight).Lo then - FEnt := Left (SLeft); - SLeft := SLeft + 1; + function Membership_Entries (N : Node_Id) return RList is + begin + if No (Next (N)) then + return Membership_Entry (N); else - FEnt := Right (SRight); - SRight := SRight + 1; + return Membership_Entry (N) or Membership_Entries (Next (N)); end if; + end Membership_Entries; - -- 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. + ---------------------- + -- Membership_Entry -- + ---------------------- - if SLeft <= Left'Last - and then Left (SLeft).Lo <= FEnt.Hi + 1 - then - FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); - SLeft := SLeft + 1; + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; - -- Eat first entry in right operand if contiguous or overlapped by - -- gathered right operand of result. + begin + -- Range case - elsif SRight <= Right'Last - and then Right (SRight).Lo <= FEnt.Hi + 1 + if Nkind (N) = N_Range then + if not Is_Static_Expression (Low_Bound (N)) + or else + not Is_Static_Expression (High_Bound (N)) then - FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); - SRight := SRight + 1; - - -- All done if no more entries to eat - + raise Non_Static; else - exit; + SLo := Expr_Value (Low_Bound (N)); + SHi := Expr_Value (High_Bound (N)); + return RList'(1 => REnt'(SLo, SHi)); end if; - end loop; - - -- Obtain result as the first entry we just computed, concatenated - -- to the "or" of the remaining results (if one operand is empty, - -- this will just concatenate with the other - - return - FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); - end "or"; - ----------------- - -- Build_Range -- - ----------------- + -- Static expression case - function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is - Result : Node_Id; + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); - begin - Result := - Make_Range (Loc, - Low_Bound => Build_Val (Lo), - High_Bound => Build_Val (Hi)); - Set_Etype (Result, Btyp); - Set_Analyzed (Result); + -- Identifier (other than static expression) case - return Result; - end Build_Range; + else pragma Assert (Nkind (N) = N_Identifier); - --------------- - -- Build_Val -- - --------------- + -- Type case - function Build_Val (V : Uint) return Node_Id is - Result : Node_Id; + if Is_Type (Entity (N)) then - begin - if Is_Enumeration_Type (Typ) then - Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); - else - Result := Make_Integer_Literal (Loc, V); - end if; + -- If type has predicates, process them - Set_Etype (Result, Btyp); - Set_Is_Static_Expression (Result); - Set_Analyzed (Result); - return Result; - end Build_Val; + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); - --------------- - -- Get_RList -- - --------------- + -- For static subtype without predicates, get range - function Get_RList (Exp : Node_Id) return RList is - Op : Node_Kind; - Val : Uint; + elsif Is_Static_Subtype (Entity (N)) then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + return RList'(1 => REnt'(SLo, SHi)); - begin - -- Static expression can only be true or false + -- Any other type makes us non-static - if Is_OK_Static_Expression (Exp) then + else + raise Non_Static; + end if; - -- For False + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. - if Expr_Value (Exp) = 0 then - return False_Range; else - return True_Range; + raise Non_Static; end if; end if; + end Membership_Entry; - -- Otherwise test node type + --------------- + -- Stat_Pred -- + --------------- - Op := Nkind (Exp); + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates - case Op is + if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then + raise Non_Static; + end if; - -- And + -- Otherwise we convert the predicate list to a range list - when N_Op_And | N_And_Then => - return Get_RList (Left_Opnd (Exp)) - and - Get_RList (Right_Opnd (Exp)); + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; - -- Or + begin + P := First (Static_Predicate (Typ)); + for J in Result'Range loop + Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); + Next (P); + end loop; - when N_Op_Or | N_Or_Else => - return Get_RList (Left_Opnd (Exp)) - or - Get_RList (Right_Opnd (Exp)); + return Result; + end; + end Stat_Pred; - -- Not + -- Start of processing for Build_Static_Predicate - when N_Op_Not => - return not Get_RList (Right_Opnd (Exp)); + begin + -- Now analyze the expression to see if it is a static predicate - -- Comparisons of type with static value + declare + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static - when N_Op_Compare => + Plist : List_Id; - -- Type is left operand + begin + -- Convert range list into a form for the static predicate. In the + -- Ranges array, we just have raw ranges, these must be converted + -- to properly typed and analyzed static expressions or range nodes. - if Is_Type_Ref (Left_Opnd (Exp)) - and then Is_OK_Static_Expression (Right_Opnd (Exp)) - then - Val := Expr_Value (Right_Opnd (Exp)); + -- Note: here we limit ranges to the ranges of the subtype, so that + -- a predicate is always false for values outside the subtype. That + -- seems fine, such values are invalid anyway, and considering them + -- to fail the predicate seems allowed and friendly, and furthermore + -- simplifies processing for case statements and loops. - -- Typ is right operand + Plist := New_List; - elsif Is_Type_Ref (Right_Opnd (Exp)) - and then Is_OK_Static_Expression (Left_Opnd (Exp)) - then - Val := Expr_Value (Left_Opnd (Exp)); + for J in Ranges'Range loop + declare + Lo : Uint := Ranges (J).Lo; + Hi : Uint := Ranges (J).Hi; - -- Invert sense of comparison + begin + -- Ignore completely out of range entry - case Op is - when N_Op_Gt => Op := N_Op_Lt; - when N_Op_Lt => Op := N_Op_Gt; - when N_Op_Ge => Op := N_Op_Le; - when N_Op_Le => Op := N_Op_Ge; - when others => null; - end case; + if Hi < TLo or else Lo > THi then + null; - -- Other cases are non-static + -- Otherwise process entry else - raise Non_Static; - end if; - - -- Construct range according to comparison operation - - case Op is - when N_Op_Eq => - return RList'(1 => REnt'(Val, Val)); - - when N_Op_Ge => - return RList'(1 => REnt'(Val, BHi)); - - when N_Op_Gt => - return RList'(1 => REnt'(Val + 1, BHi)); - - when N_Op_Le => - return RList'(1 => REnt'(BLo, Val)); - - when N_Op_Lt => - return RList'(1 => REnt'(BLo, Val - 1)); + -- Adjust out of range value to subtype range - when N_Op_Ne => - return RList'(REnt'(BLo, Val - 1), - REnt'(Val + 1, BHi)); + if Lo < TLo then + Lo := TLo; + end if; - when others => - raise Program_Error; - end case; + if Hi > THi then + Hi := THi; + end if; - -- Membership (IN) + -- Convert range into required form - when N_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; + Append_To (Plist, Build_Range (Lo, Hi)); end if; + end; + end loop; - if Present (Right_Opnd (Exp)) then - return Membership_Entry (Right_Opnd (Exp)); - else - return Membership_Entries (First (Alternatives (Exp))); - end if; + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. - -- Negative membership (NOT IN) + Set_Static_Predicate (Typ, Plist); - when N_Not_In => - if not Is_Type_Ref (Left_Opnd (Exp)) then - raise Non_Static; - end if; + -- The processing for static predicates put the expression into + -- canonical form as a series of ranges. It also eliminated + -- duplicates and collapsed and combined ranges. We might as well + -- replace the alternatives list of the right operand of the + -- membership test with the static predicate list, which will + -- usually be more efficient. - if Present (Right_Opnd (Exp)) then - return not Membership_Entry (Right_Opnd (Exp)); - else - return not Membership_Entries (First (Alternatives (Exp))); - end if; + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; - -- Function call, may be call to static predicate + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); - when N_Function_Call => - if Is_Entity_Name (Name (Exp)) then - declare - Ent : constant Entity_Id := Entity (Name (Exp)); - begin - if Is_Predicate_Function (Ent) - or else - Is_Predicate_Function_M (Ent) - then - return Stat_Pred (Etype (First_Formal (Ent))); - end if; - end; + if Nkind (New_Node) = N_Range then + Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); + Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); end if; - -- Other function call cases are non-static + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; - raise Non_Static; + -- If empty list, replace by False - -- Qualified expression, dig out the expression + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); - when N_Qualified_Expression => - return Get_RList (Expression (Exp)); + -- Else replace by set membership test - -- Xor operator + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); - when N_Op_Xor => - return (Get_RList (Left_Opnd (Exp)) - and not Get_RList (Right_Opnd (Exp))) - or (Get_RList (Right_Opnd (Exp)) - and not Get_RList (Left_Opnd (Exp))); + -- Resolve new expression in function context - -- Any other node type is non-static + Install_Formals (Predicate_Function (Typ)); + Push_Scope (Predicate_Function (Typ)); + Analyze_And_Resolve (Expr, Standard_Boolean); + Pop_Scope; + end if; + end; + end; - when others => - raise Non_Static; - end case; - end Get_RList; + -- If non-static, return doing nothing - ------------ - -- Hi_Val -- - ------------ + exception + when Non_Static => + return; + end Build_Static_Predicate; - function Hi_Val (N : Node_Id) return Uint is - begin - if Is_Static_Expression (N) then - return Expr_Value (N); - else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (High_Bound (N)); - end if; - end Hi_Val; + ----------------------------------------- + -- Check_Aspect_At_End_Of_Declarations -- + ----------------------------------------- - -------------- - -- Is_False -- - -------------- + procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is + Ent : constant Entity_Id := Entity (ASN); + Ident : constant Node_Id := Identifier (ASN); + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); - function Is_False (R : RList) return Boolean is - begin - return R'Length = 0; - end Is_False; + End_Decl_Expr : constant Node_Id := Entity (Ident); + -- Expression to be analyzed at end of declarations - ------------- - -- Is_True -- - ------------- + Freeze_Expr : constant Node_Id := Expression (ASN); + -- Expression from call to Check_Aspect_At_Freeze_Point - function Is_True (R : RList) return Boolean is - begin - return R'Length = 1 - and then R (R'First).Lo = BLo - and then R (R'First).Hi = BHi; - end Is_True; + T : constant Entity_Id := Etype (Freeze_Expr); + -- Type required for preanalyze call - ----------------- - -- Is_Type_Ref -- - ----------------- + Err : Boolean; + -- Set False if error - function Is_Type_Ref (N : Node_Id) return Boolean is - begin - return Nkind (N) = N_Identifier and then Chars (N) = Nam; - end Is_Type_Ref; + -- On entry to this procedure, Entity (Ident) contains a copy of the + -- original expression from the aspect, saved for this purpose, and + -- but Expression (Ident) is a preanalyzed copy of the expression, + -- preanalyzed just after the freeze point. - ------------ - -- Lo_Val -- - ------------ + procedure Check_Overloaded_Name; + -- For aspects whose expression is simply a name, this routine checks if + -- the name is overloaded or not. If so, it verifies there is an + -- interpretation that matches the entity obtained at the freeze point, + -- otherwise the compiler complains. - function Lo_Val (N : Node_Id) return Uint is + --------------------------- + -- Check_Overloaded_Name -- + --------------------------- + + procedure Check_Overloaded_Name is begin - if Is_Static_Expression (N) then - return Expr_Value (N); + if not Is_Overloaded (End_Decl_Expr) then + Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + else - pragma Assert (Nkind (N) = N_Range); - return Expr_Value (Low_Bound (N)); - end if; - end Lo_Val; + Err := True; - ------------------------ - -- Membership_Entries -- - ------------------------ + declare + Index : Interp_Index; + It : Interp; - function Membership_Entries (N : Node_Id) return RList is - begin - if No (Next (N)) then - return Membership_Entry (N); - else - return Membership_Entry (N) or Membership_Entries (Next (N)); + begin + Get_First_Interp (End_Decl_Expr, Index, It); + while Present (It.Typ) loop + if It.Nam = Entity (Freeze_Expr) then + Err := False; + exit; + end if; + + Get_Next_Interp (Index, It); + end loop; + end; end if; - end Membership_Entries; + end Check_Overloaded_Name; - ---------------------- - -- Membership_Entry -- - ---------------------- + -- Start of processing for Check_Aspect_At_End_Of_Declarations - function Membership_Entry (N : Node_Id) return RList is - Val : Uint; - SLo : Uint; - SHi : Uint; + begin + -- Case of aspects Dimension, Dimension_System and Synchronization - begin - -- Range case + if A_Id = Aspect_Synchronization then + return; - if Nkind (N) = N_Range then - if not Is_Static_Expression (Low_Bound (N)) - or else - not Is_Static_Expression (High_Bound (N)) - then - raise Non_Static; - else - SLo := Expr_Value (Low_Bound (N)); - SHi := Expr_Value (High_Bound (N)); - return RList'(1 => REnt'(SLo, SHi)); - end if; + -- Case of stream attributes, just have to compare entities. However, + -- the expression is just a name (possibly overloaded), and there may + -- be stream operations declared for unrelated types, so we just need + -- to verify that one of these interpretations is the one available at + -- at the freeze point. - -- Static expression case + elsif A_Id = Aspect_Input or else + A_Id = Aspect_Output or else + A_Id = Aspect_Read or else + A_Id = Aspect_Write + then + Analyze (End_Decl_Expr); + Check_Overloaded_Name; - elsif Is_Static_Expression (N) then - Val := Expr_Value (N); - return RList'(1 => REnt'(Val, Val)); + elsif A_Id = Aspect_Variable_Indexing or else + A_Id = Aspect_Constant_Indexing or else + A_Id = Aspect_Default_Iterator or else + A_Id = Aspect_Iterator_Element + then + -- Make type unfrozen before analysis, to prevent spurious errors + -- about late attributes. - -- Identifier (other than static expression) case + Set_Is_Frozen (Ent, False); + Analyze (End_Decl_Expr); + Set_Is_Frozen (Ent, True); - else pragma Assert (Nkind (N) = N_Identifier); + -- If the end of declarations comes before any other freeze + -- point, the Freeze_Expr is not analyzed: no check needed. - -- Type case + if Analyzed (Freeze_Expr) and then not In_Instance then + Check_Overloaded_Name; + else + Err := False; + end if; - if Is_Type (Entity (N)) then + -- All other cases - -- If type has predicates, process them + else + -- In a generic context the aspect expressions have not been + -- preanalyzed, so do it now. There are no conformance checks + -- to perform in this case. - if Has_Predicates (Entity (N)) then - return Stat_Pred (Entity (N)); + if No (T) then + Check_Aspect_At_Freeze_Point (ASN); + return; - -- For static subtype without predicates, get range + -- The default values attributes may be defined in the private part, + -- and the analysis of the expression may take place when only the + -- partial view is visible. The expression must be scalar, so use + -- the full view to resolve. - elsif Is_Static_Subtype (Entity (N)) then - SLo := Expr_Value (Type_Low_Bound (Entity (N))); - SHi := Expr_Value (Type_High_Bound (Entity (N))); - return RList'(1 => REnt'(SLo, SHi)); + elsif (A_Id = Aspect_Default_Value + or else + A_Id = Aspect_Default_Component_Value) + and then Is_Private_Type (T) + then + Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); + else + Preanalyze_Spec_Expression (End_Decl_Expr, T); + end if; - -- Any other type makes us non-static + Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr); + end if; - else - raise Non_Static; - end if; + -- Output error message if error - -- Any other kind of identifier in predicate (e.g. a non-static - -- expression value) means this is not a static predicate. + if Err then + Error_Msg_NE + ("visibility of aspect for& changes after freeze point", + ASN, Ent); + Error_Msg_NE + ("info: & is frozen here, aspects evaluated at this point??", + Freeze_Node (Ent), Ent); + end if; + end Check_Aspect_At_End_Of_Declarations; - else - raise Non_Static; - end if; - end if; - end Membership_Entry; + ---------------------------------- + -- Check_Aspect_At_Freeze_Point -- + ---------------------------------- - --------------- - -- Stat_Pred -- - --------------- + procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is + Ident : constant Node_Id := Identifier (ASN); + -- Identifier (use Entity field to save expression) - function Stat_Pred (Typ : Entity_Id) return RList is - begin - -- Not static if type does not have static predicates + A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); - if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then - raise Non_Static; - end if; + T : Entity_Id := Empty; + -- Type required for preanalyze call - -- Otherwise we convert the predicate list to a range list + begin + -- On entry to this procedure, Entity (Ident) contains a copy of the + -- original expression from the aspect, saved for this purpose. - declare - Result : RList (1 .. List_Length (Static_Predicate (Typ))); - P : Node_Id; + -- On exit from this procedure Entity (Ident) is unchanged, still + -- containing that copy, but Expression (Ident) is a preanalyzed copy + -- of the expression, preanalyzed just after the freeze point. - begin - P := First (Static_Predicate (Typ)); - for J in Result'Range loop - Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); - Next (P); - end loop; + -- Make a copy of the expression to be preanalyzed - return Result; - end; - end Stat_Pred; + Set_Expression (ASN, New_Copy_Tree (Entity (Ident))); - -- Start of processing for Build_Static_Predicate + -- Find type for preanalyze call - begin - -- Now analyze the expression to see if it is a static predicate + case A_Id is - declare - Ranges : constant RList := Get_RList (Expr); - -- Range list from expression if it is static + -- No_Aspect should be impossible - Plist : List_Id; + when No_Aspect => + raise Program_Error; + + -- Aspects taking an optional boolean argument - begin - -- Convert range list into a form for the static predicate. In the - -- Ranges array, we just have raw ranges, these must be converted - -- to properly typed and analyzed static expressions or range nodes. + when Boolean_Aspects | + Library_Unit_Aspects => - -- Note: here we limit ranges to the ranges of the subtype, so that - -- a predicate is always false for values outside the subtype. That - -- seems fine, such values are invalid anyway, and considering them - -- to fail the predicate seems allowed and friendly, and furthermore - -- simplifies processing for case statements and loops. + T := Standard_Boolean; - Plist := New_List; + -- Aspects corresponding to attribute definition clauses - for J in Ranges'Range loop - declare - Lo : Uint := Ranges (J).Lo; - Hi : Uint := Ranges (J).Hi; + when Aspect_Address => + T := RTE (RE_Address); - begin - -- Ignore completely out of range entry + when Aspect_Attach_Handler => + T := RTE (RE_Interrupt_ID); - if Hi < TLo or else Lo > THi then - null; + when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => + T := RTE (RE_Bit_Order); - -- Otherwise process entry + when Aspect_Convention => + return; - else - -- Adjust out of range value to subtype range + when Aspect_CPU => + T := RTE (RE_CPU_Range); - if Lo < TLo then - Lo := TLo; - end if; + -- Default_Component_Value is resolved with the component type - if Hi > THi then - Hi := THi; - end if; + when Aspect_Default_Component_Value => + T := Component_Type (Entity (ASN)); - -- Convert range into required form + -- Default_Value is resolved with the type entity in question - Append_To (Plist, Build_Range (Lo, Hi)); - end if; - end; - end loop; + when Aspect_Default_Value => + T := Entity (ASN); - -- Processing was successful and all entries were static, so now we - -- can store the result as the predicate list. + -- 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. - Set_Static_Predicate (Typ, Plist); + when Aspect_Depends => + return; - -- The processing for static predicates put the expression into - -- canonical form as a series of ranges. It also eliminated - -- duplicates and collapsed and combined ranges. We might as well - -- replace the alternatives list of the right operand of the - -- membership test with the static predicate list, which will - -- usually be more efficient. + when Aspect_Dispatching_Domain => + T := RTE (RE_Dispatching_Domain); - declare - New_Alts : constant List_Id := New_List; - Old_Node : Node_Id; - New_Node : Node_Id; + when Aspect_External_Tag => + T := Standard_String; - begin - Old_Node := First (Plist); - while Present (Old_Node) loop - New_Node := New_Copy (Old_Node); + when Aspect_External_Name => + T := Standard_String; - if Nkind (New_Node) = N_Range then - Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); - Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); - end if; + -- 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. - Append_To (New_Alts, New_Node); - Next (Old_Node); - end loop; + when Aspect_Global => + return; - -- If empty list, replace by False + when Aspect_Link_Name => + T := Standard_String; - if Is_Empty_List (New_Alts) then - Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); + when Aspect_Priority | Aspect_Interrupt_Priority => + T := Standard_Integer; - -- Else replace by set membership test + when Aspect_Relative_Deadline => + T := RTE (RE_Time_Span); - else - Rewrite (Expr, - Make_In (Loc, - Left_Opnd => Make_Identifier (Loc, Nam), - Right_Opnd => Empty, - Alternatives => New_Alts)); + when Aspect_Small => + T := Universal_Real; - -- Resolve new expression in function context + -- For a simple storage pool, we have to retrieve the type of the + -- pool object associated with the aspect's corresponding attribute + -- definition clause. - Install_Formals (Predicate_Function (Typ)); - Push_Scope (Predicate_Function (Typ)); - Analyze_And_Resolve (Expr, Standard_Boolean); - Pop_Scope; - end if; - end; - end; + when Aspect_Simple_Storage_Pool => + T := Etype (Expression (Aspect_Rep_Item (ASN))); - -- If non-static, return doing nothing + when Aspect_Storage_Pool => + T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); - exception - when Non_Static => - return; - end Build_Static_Predicate; + when Aspect_Alignment | + Aspect_Component_Size | + Aspect_Machine_Radix | + Aspect_Object_Size | + Aspect_Size | + Aspect_Storage_Size | + Aspect_Stream_Size | + Aspect_Value_Size => + T := Any_Integer; - ----------------------------------------- - -- Check_Aspect_At_End_Of_Declarations -- - ----------------------------------------- + when Aspect_Synchronization => + return; - procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is - Ent : constant Entity_Id := Entity (ASN); - Ident : constant Node_Id := Identifier (ASN); - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); + -- Special case, the expression of these aspects is just an entity + -- that does not need any resolution, so just analyze. - End_Decl_Expr : constant Node_Id := Entity (Ident); - -- Expression to be analyzed at end of declarations + when Aspect_Input | + Aspect_Output | + Aspect_Read | + Aspect_Suppress | + Aspect_Unsuppress | + Aspect_Warnings | + Aspect_Write => + Analyze (Expression (ASN)); + return; - Freeze_Expr : constant Node_Id := Expression (ASN); - -- Expression from call to Check_Aspect_At_Freeze_Point + -- Same for Iterator aspects, where the expression is a function + -- name. Legality rules are checked separately. - T : constant Entity_Id := Etype (Freeze_Expr); - -- Type required for preanalyze call + when Aspect_Constant_Indexing | + Aspect_Default_Iterator | + Aspect_Iterator_Element | + Aspect_Variable_Indexing => + Analyze (Expression (ASN)); + return; - Err : Boolean; - -- Set False if error + -- Invariant/Predicate take boolean expressions - -- On entry to this procedure, Entity (Ident) contains a copy of the - -- original expression from the aspect, saved for this purpose, and - -- but Expression (Ident) is a preanalyzed copy of the expression, - -- preanalyzed just after the freeze point. + when Aspect_Dynamic_Predicate | + Aspect_Invariant | + Aspect_Predicate | + Aspect_Static_Predicate | + Aspect_Type_Invariant => + T := Standard_Boolean; - procedure Check_Overloaded_Name; - -- For aspects whose expression is simply a name, this routine checks if - -- the name is overloaded or not. If so, it verifies there is an - -- interpretation that matches the entity obtained at the freeze point, - -- otherwise the compiler complains. + -- Here is the list of aspects that don't require delay analysis - --------------------------- - -- Check_Overloaded_Name -- - --------------------------- + when Aspect_Abstract_State | + Aspect_Contract_Cases | + Aspect_Dimension | + Aspect_Dimension_System | + Aspect_Implicit_Dereference | + Aspect_Post | + Aspect_Postcondition | + Aspect_Pre | + Aspect_Precondition | + Aspect_Refined_Depends | + Aspect_Refined_Global | + Aspect_Refined_Post | + Aspect_Refined_Pre | + Aspect_SPARK_Mode | + Aspect_Test_Case => + raise Program_Error; - procedure Check_Overloaded_Name is - begin - if not Is_Overloaded (End_Decl_Expr) then - Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); + end case; - else - Err := True; + -- Do the preanalyze call - declare - Index : Interp_Index; - It : Interp; + Preanalyze_Spec_Expression (Expression (ASN), T); + end Check_Aspect_At_Freeze_Point; - begin - Get_First_Interp (End_Decl_Expr, Index, It); - while Present (It.Typ) loop - if It.Nam = Entity (Freeze_Expr) then - Err := False; - exit; - end if; + ----------------------------------- + -- Check_Constant_Address_Clause -- + ----------------------------------- - Get_Next_Interp (Index, It); - end loop; - end; - end if; - end Check_Overloaded_Name; + procedure Check_Constant_Address_Clause + (Expr : Node_Id; + U_Ent : Entity_Id) + is + procedure Check_At_Constant_Address (Nod : Node_Id); + -- Checks that the given node N represents a name whose 'Address is + -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the + -- address value is the same at the point of declaration of U_Ent and at + -- the time of elaboration of the address clause. - -- Start of processing for Check_Aspect_At_End_Of_Declarations + procedure Check_Expr_Constants (Nod : Node_Id); + -- Checks that Nod meets the requirements for a constant address clause + -- in the sense of the enclosing procedure. - begin - -- Case of aspects Dimension, Dimension_System and Synchronization + procedure Check_List_Constants (Lst : List_Id); + -- Check that all elements of list Lst meet the requirements for a + -- constant address clause in the sense of the enclosing procedure. - if A_Id = Aspect_Synchronization then - return; + ------------------------------- + -- Check_At_Constant_Address -- + ------------------------------- - -- Case of stream attributes, just have to compare entities. However, - -- the expression is just a name (possibly overloaded), and there may - -- be stream operations declared for unrelated types, so we just need - -- to verify that one of these interpretations is the one available at - -- at the freeze point. + procedure Check_At_Constant_Address (Nod : Node_Id) is + begin + if Is_Entity_Name (Nod) then + if Present (Address_Clause (Entity ((Nod)))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("address for& cannot" & + " depend on another address clause! (RM 13.1(22))!", + Nod, U_Ent); - elsif A_Id = Aspect_Input or else - A_Id = Aspect_Output or else - A_Id = Aspect_Read or else - A_Id = Aspect_Write - then - Analyze (End_Decl_Expr); - Check_Overloaded_Name; + elsif In_Same_Source_Unit (Entity (Nod), U_Ent) + and then Sloc (U_Ent) < Sloc (Entity (Nod)) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Entity (Nod)); + end if; - elsif A_Id = Aspect_Variable_Indexing or else - A_Id = Aspect_Constant_Indexing or else - A_Id = Aspect_Default_Iterator or else - A_Id = Aspect_Iterator_Element - then - -- Make type unfrozen before analysis, to prevent spurious errors - -- about late attributes. + elsif Nkind (Nod) = N_Selected_Component then + declare + T : constant Entity_Id := Etype (Prefix (Nod)); - Set_Is_Frozen (Ent, False); - Analyze (End_Decl_Expr); - Set_Is_Frozen (Ent, True); + begin + if (Is_Record_Type (T) + and then Has_Discriminants (T)) + or else + (Is_Access_Type (T) + and then Is_Record_Type (Designated_Type (T)) + and then Has_Discriminants (Designated_Type (T))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_N + ("\address cannot depend on component" & + " of discriminated record (RM 13.1(22))!", + Nod); + else + Check_At_Constant_Address (Prefix (Nod)); + end if; + end; - -- If the end of declarations comes before any other freeze - -- point, the Freeze_Expr is not analyzed: no check needed. + elsif Nkind (Nod) = N_Indexed_Component then + Check_At_Constant_Address (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); - if Analyzed (Freeze_Expr) and then not In_Instance then - Check_Overloaded_Name; else - Err := False; + Check_Expr_Constants (Nod); end if; + end Check_At_Constant_Address; - -- All other cases - - else - -- In a generic context the aspect expressions have not been - -- preanalyzed, so do it now. There are no conformance checks - -- to perform in this case. - - if No (T) then - Check_Aspect_At_Freeze_Point (ASN); - return; + -------------------------- + -- Check_Expr_Constants -- + -------------------------- - -- The default values attributes may be defined in the private part, - -- and the analysis of the expression may take place when only the - -- partial view is visible. The expression must be scalar, so use - -- the full view to resolve. + procedure Check_Expr_Constants (Nod : Node_Id) is + Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); + Ent : Entity_Id := Empty; - elsif (A_Id = Aspect_Default_Value - or else - A_Id = Aspect_Default_Component_Value) - and then Is_Private_Type (T) + begin + if Nkind (Nod) in N_Has_Etype + and then Etype (Nod) = Any_Type then - Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); - else - Preanalyze_Spec_Expression (End_Decl_Expr, T); + return; end if; - Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr); - end if; - - -- Output error message if error + case Nkind (Nod) is + when N_Empty | N_Error => + return; - if Err then - Error_Msg_NE - ("visibility of aspect for& changes after freeze point", - ASN, Ent); - Error_Msg_NE - ("info: & is frozen here, aspects evaluated at this point??", - Freeze_Node (Ent), Ent); - end if; - end Check_Aspect_At_End_Of_Declarations; + when N_Identifier | N_Expanded_Name => + Ent := Entity (Nod); - ---------------------------------- - -- Check_Aspect_At_Freeze_Point -- - ---------------------------------- + -- We need to look at the original node if it is different + -- from the node, since we may have rewritten things and + -- substituted an identifier representing the rewrite. - procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is - Ident : constant Node_Id := Identifier (ASN); - -- Identifier (use Entity field to save expression) + if Original_Node (Nod) /= Nod then + Check_Expr_Constants (Original_Node (Nod)); - A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); + -- If the node is an object declaration without initial + -- value, some code has been expanded, and the expression + -- is not constant, even if the constituents might be + -- acceptable, as in A'Address + offset. - T : Entity_Id := Empty; - -- Type required for preanalyze call + if Ekind (Ent) = E_Variable + and then + Nkind (Declaration_Node (Ent)) = N_Object_Declaration + and then + No (Expression (Declaration_Node (Ent))) + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); - begin - -- On entry to this procedure, Entity (Ident) contains a copy of the - -- original expression from the aspect, saved for this purpose. + -- If entity is constant, it may be the result of expanding + -- a check. We must verify that its declaration appears + -- before the object in question, else we also reject the + -- address clause. - -- On exit from this procedure Entity (Ident) is unchanged, still - -- containing that copy, but Expression (Ident) is a preanalyzed copy - -- of the expression, preanalyzed just after the freeze point. + elsif Ekind (Ent) = E_Constant + and then In_Same_Source_Unit (Ent, U_Ent) + and then Sloc (Ent) > Loc_U_Ent + then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + end if; - -- Make a copy of the expression to be preanalyzed + return; + end if; - Set_Expression (ASN, New_Copy_Tree (Entity (Ident))); + -- Otherwise look at the identifier and see if it is OK - -- Find type for preanalyze call + if Ekind_In (Ent, E_Named_Integer, E_Named_Real) + or else Is_Type (Ent) + then + return; - case A_Id is + elsif + Ekind (Ent) = E_Constant + or else + Ekind (Ent) = E_In_Parameter + then + -- This is the case where we must have Ent defined before + -- U_Ent. Clearly if they are in different units this + -- requirement is met since the unit containing Ent is + -- already processed. - -- No_Aspect should be impossible + if not In_Same_Source_Unit (Ent, U_Ent) then + return; - when No_Aspect => - raise Program_Error; + -- Otherwise location of Ent must be before the location + -- of U_Ent, that's what prior defined means. - -- Aspects taking an optional boolean argument + elsif Sloc (Ent) < Loc_U_Ent then + return; - when Boolean_Aspects | - Library_Unit_Aspects => + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_Node_2 := U_Ent; + Error_Msg_NE + ("\& must be defined before & (RM 13.1(22))!", + Nod, Ent); + end if; - T := Standard_Boolean; + elsif Nkind (Original_Node (Nod)) = N_Function_Call then + Check_Expr_Constants (Original_Node (Nod)); - -- Aspects corresponding to attribute definition clauses + else + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); - when Aspect_Address => - T := RTE (RE_Address); + if Comes_From_Source (Ent) then + Error_Msg_NE + ("\reference to variable& not allowed" + & " (RM 13.1(22))!", Nod, Ent); + else + Error_Msg_N + ("non-static expression not allowed" + & " (RM 13.1(22))!", Nod); + end if; + end if; - when Aspect_Attach_Handler => - T := RTE (RE_Interrupt_ID); + when N_Integer_Literal => - when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => - T := RTE (RE_Bit_Order); + -- If this is a rewritten unchecked conversion, in a system + -- where Address is an integer type, always use the base type + -- for a literal value. This is user-friendly and prevents + -- order-of-elaboration issues with instances of unchecked + -- conversion. - when Aspect_Convention => - return; + if Nkind (Original_Node (Nod)) = N_Function_Call then + Set_Etype (Nod, Base_Type (Etype (Nod))); + end if; - when Aspect_CPU => - T := RTE (RE_CPU_Range); + when N_Real_Literal | + N_String_Literal | + N_Character_Literal => + return; - -- Default_Component_Value is resolved with the component type + when N_Range => + Check_Expr_Constants (Low_Bound (Nod)); + Check_Expr_Constants (High_Bound (Nod)); - when Aspect_Default_Component_Value => - T := Component_Type (Entity (ASN)); + when N_Explicit_Dereference => + Check_Expr_Constants (Prefix (Nod)); - -- Default_Value is resolved with the type entity in question + when N_Indexed_Component => + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); - when Aspect_Default_Value => - T := Entity (ASN); + when N_Slice => + Check_Expr_Constants (Prefix (Nod)); + Check_Expr_Constants (Discrete_Range (Nod)); - -- 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 N_Selected_Component => + Check_Expr_Constants (Prefix (Nod)); - when Aspect_Depends => - return; + when N_Attribute_Reference => + if Nam_In (Attribute_Name (Nod), Name_Address, + Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) + then + Check_At_Constant_Address (Prefix (Nod)); - when Aspect_Dispatching_Domain => - T := RTE (RE_Dispatching_Domain); + else + Check_Expr_Constants (Prefix (Nod)); + Check_List_Constants (Expressions (Nod)); + end if; - when Aspect_External_Tag => - T := Standard_String; + when N_Aggregate => + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); - when Aspect_External_Name => - T := Standard_String; + when N_Component_Association => + Check_Expr_Constants (Expression (Nod)); - -- 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 N_Extension_Aggregate => + Check_Expr_Constants (Ancestor_Part (Nod)); + Check_List_Constants (Component_Associations (Nod)); + Check_List_Constants (Expressions (Nod)); - when Aspect_Global => - return; + when N_Null => + return; - when Aspect_Link_Name => - T := Standard_String; + when N_Binary_Op | N_Short_Circuit | N_Membership_Test => + Check_Expr_Constants (Left_Opnd (Nod)); + Check_Expr_Constants (Right_Opnd (Nod)); - when Aspect_Priority | Aspect_Interrupt_Priority => - T := Standard_Integer; + when N_Unary_Op => + Check_Expr_Constants (Right_Opnd (Nod)); - when Aspect_Relative_Deadline => - T := RTE (RE_Time_Span); + when N_Type_Conversion | + N_Qualified_Expression | + N_Allocator | + N_Unchecked_Type_Conversion => + Check_Expr_Constants (Expression (Nod)); - when Aspect_Small => - T := Universal_Real; + when N_Function_Call => + if not Is_Pure (Entity (Name (Nod))) then + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); - -- For a simple storage pool, we have to retrieve the type of the - -- pool object associated with the aspect's corresponding attribute - -- definition clause. + Error_Msg_NE + ("\function & is not pure (RM 13.1(22))!", + Nod, Entity (Name (Nod))); - when Aspect_Simple_Storage_Pool => - T := Etype (Expression (Aspect_Rep_Item (ASN))); + else + Check_List_Constants (Parameter_Associations (Nod)); + end if; - when Aspect_Storage_Pool => - T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); + when N_Parameter_Association => + Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); - when Aspect_Alignment | - Aspect_Component_Size | - Aspect_Machine_Radix | - Aspect_Object_Size | - Aspect_Size | - Aspect_Storage_Size | - Aspect_Stream_Size | - Aspect_Value_Size => - T := Any_Integer; + when others => + Error_Msg_NE + ("invalid address clause for initialized object &!", + Nod, U_Ent); + Error_Msg_NE + ("\must be constant defined before& (RM 13.1(22))!", + Nod, U_Ent); + end case; + end Check_Expr_Constants; - when Aspect_Synchronization => - return; + -------------------------- + -- Check_List_Constants -- + -------------------------- - -- Special case, the expression of these aspects is just an entity - -- that does not need any resolution, so just analyze. + procedure Check_List_Constants (Lst : List_Id) is + Nod1 : Node_Id; - when Aspect_Input | - Aspect_Output | - Aspect_Read | - Aspect_Suppress | - Aspect_Unsuppress | - Aspect_Warnings | - Aspect_Write => - Analyze (Expression (ASN)); - return; + begin + if Present (Lst) then + Nod1 := First (Lst); + while Present (Nod1) loop + Check_Expr_Constants (Nod1); + Next (Nod1); + end loop; + end if; + end Check_List_Constants; - -- Same for Iterator aspects, where the expression is a function - -- name. Legality rules are checked separately. + -- Start of processing for Check_Constant_Address_Clause - when Aspect_Constant_Indexing | - Aspect_Default_Iterator | - Aspect_Iterator_Element | - Aspect_Variable_Indexing => - Analyze (Expression (ASN)); - return; + begin + -- If rep_clauses are to be ignored, no need for legality checks. In + -- particular, no need to pester user about rep clauses that violate + -- the rule on constant addresses, given that these clauses will be + -- removed by Freeze before they reach the back end. - -- Invariant/Predicate take boolean expressions + if not Ignore_Rep_Clauses then + Check_Expr_Constants (Expr); + end if; + end Check_Constant_Address_Clause; - when Aspect_Dynamic_Predicate | - Aspect_Invariant | - Aspect_Predicate | - Aspect_Static_Predicate | - Aspect_Type_Invariant => - T := Standard_Boolean; + ---------------------------------------- + -- Check_Record_Representation_Clause -- + ---------------------------------------- - -- Here is the list of aspects that don't require delay analysis + procedure Check_Record_Representation_Clause (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ident : constant Node_Id := Identifier (N); + Rectype : Entity_Id; + Fent : Entity_Id; + CC : Node_Id; + Fbit : Uint; + Lbit : Uint; + Hbit : Uint := Uint_0; + Comp : Entity_Id; + Pcomp : Entity_Id; - when Aspect_Abstract_State | - Aspect_Contract_Cases | - Aspect_Dimension | - Aspect_Dimension_System | - Aspect_Implicit_Dereference | - Aspect_Post | - Aspect_Postcondition | - Aspect_Pre | - Aspect_Precondition | - Aspect_Refined_Depends | - Aspect_Refined_Global | - Aspect_Refined_Post | - Aspect_Refined_Pre | - Aspect_SPARK_Mode | - Aspect_Test_Case => - raise Program_Error; + Max_Bit_So_Far : Uint; + -- Records the maximum bit position so far. If all field positions + -- are monotonically increasing, then we can skip the circuit for + -- checking for overlap, since no overlap is possible. - end case; + Tagged_Parent : Entity_Id := Empty; + -- This is set in the case of a derived tagged type for which we have + -- Is_Fully_Repped_Tagged_Type True (indicating that all components are + -- positioned by record representation clauses). In this case we must + -- check for overlap between components of this tagged type, and the + -- components of its parent. Tagged_Parent will point to this parent + -- type. For all other cases Tagged_Parent is left set to Empty. - -- Do the preanalyze call + Parent_Last_Bit : Uint; + -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the + -- last bit position for any field in the parent type. We only need to + -- check overlap for fields starting below this point. - Preanalyze_Spec_Expression (Expression (ASN), T); - end Check_Aspect_At_Freeze_Point; + Overlap_Check_Required : Boolean; + -- Used to keep track of whether or not an overlap check is required - ----------------------------------- - -- Check_Constant_Address_Clause -- - ----------------------------------- + Overlap_Detected : Boolean := False; + -- Set True if an overlap is detected - procedure Check_Constant_Address_Clause - (Expr : Node_Id; - U_Ent : Entity_Id) - is - procedure Check_At_Constant_Address (Nod : Node_Id); - -- Checks that the given node N represents a name whose 'Address is - -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the - -- address value is the same at the point of declaration of U_Ent and at - -- the time of elaboration of the address clause. + Ccount : Natural := 0; + -- Number of component clauses in record rep clause - procedure Check_Expr_Constants (Nod : Node_Id); - -- Checks that Nod meets the requirements for a constant address clause - -- in the sense of the enclosing procedure. + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); + -- Given two entities for record components or discriminants, checks + -- if they have overlapping component clauses and issues errors if so. - procedure Check_List_Constants (Lst : List_Id); - -- Check that all elements of list Lst meet the requirements for a - -- constant address clause in the sense of the enclosing procedure. + procedure Find_Component; + -- Finds component entity corresponding to current component clause (in + -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin + -- start/stop bits for the field. If there is no matching component or + -- if the matching component does not have a component clause, then + -- that's an error and Comp is set to Empty, but no error message is + -- issued, since the message was already given. Comp is also set to + -- Empty if the current "component clause" is in fact a pragma. - ------------------------------- - -- Check_At_Constant_Address -- - ------------------------------- + ----------------------------- + -- Check_Component_Overlap -- + ----------------------------- + + procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is + CC1 : constant Node_Id := Component_Clause (C1_Ent); + CC2 : constant Node_Id := Component_Clause (C2_Ent); - procedure Check_At_Constant_Address (Nod : Node_Id) is begin - if Is_Entity_Name (Nod) then - if Present (Address_Clause (Entity ((Nod)))) then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("address for& cannot" & - " depend on another address clause! (RM 13.1(22))!", - Nod, U_Ent); + if Present (CC1) and then Present (CC2) then - elsif In_Same_Source_Unit (Entity (Nod), U_Ent) - and then Sloc (U_Ent) < Sloc (Entity (Nod)) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_Node_2 := U_Ent; - Error_Msg_NE - ("\& must be defined before & (RM 13.1(22))!", - Nod, Entity (Nod)); + -- 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 Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then + return; end if; - elsif Nkind (Nod) = N_Selected_Component then + -- Here we check if the two fields overlap + declare - T : constant Entity_Id := Etype (Prefix (Nod)); + S1 : constant Uint := Component_Bit_Offset (C1_Ent); + S2 : constant Uint := Component_Bit_Offset (C2_Ent); + E1 : constant Uint := S1 + Esize (C1_Ent); + E2 : constant Uint := S2 + Esize (C2_Ent); begin - if (Is_Record_Type (T) - and then Has_Discriminants (T)) - or else - (Is_Access_Type (T) - and then Is_Record_Type (Designated_Type (T)) - and then Has_Discriminants (Designated_Type (T))) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_N - ("\address cannot depend on component" & - " of discriminated record (RM 13.1(22))!", - Nod); + if E2 <= S1 or else E1 <= S2 then + null; else - Check_At_Constant_Address (Prefix (Nod)); + Error_Msg_Node_2 := Component_Name (CC2); + Error_Msg_Sloc := Sloc (Error_Msg_Node_2); + Error_Msg_Node_1 := Component_Name (CC1); + Error_Msg_N + ("component& overlaps & #", Component_Name (CC1)); + Overlap_Detected := True; end if; end; - - elsif Nkind (Nod) = N_Indexed_Component then - Check_At_Constant_Address (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); - - else - Check_Expr_Constants (Nod); - end if; - end Check_At_Constant_Address; - - -------------------------- - -- Check_Expr_Constants -- - -------------------------- - - procedure Check_Expr_Constants (Nod : Node_Id) is - Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); - Ent : Entity_Id := Empty; - - begin - if Nkind (Nod) in N_Has_Etype - and then Etype (Nod) = Any_Type - then - return; end if; + end Check_Component_Overlap; - case Nkind (Nod) is - when N_Empty | N_Error => - return; - - when N_Identifier | N_Expanded_Name => - Ent := Entity (Nod); - - -- We need to look at the original node if it is different - -- from the node, since we may have rewritten things and - -- substituted an identifier representing the rewrite. + -------------------- + -- Find_Component -- + -------------------- - if Original_Node (Nod) /= Nod then - Check_Expr_Constants (Original_Node (Nod)); + procedure Find_Component is - -- If the node is an object declaration without initial - -- value, some code has been expanded, and the expression - -- is not constant, even if the constituents might be - -- acceptable, as in A'Address + offset. + procedure Search_Component (R : Entity_Id); + -- Search components of R for a match. If found, Comp is set - if Ekind (Ent) = E_Variable - and then - Nkind (Declaration_Node (Ent)) = N_Object_Declaration - and then - No (Expression (Declaration_Node (Ent))) - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + ---------------------- + -- Search_Component -- + ---------------------- - -- If entity is constant, it may be the result of expanding - -- a check. We must verify that its declaration appears - -- before the object in question, else we also reject the - -- address clause. + procedure Search_Component (R : Entity_Id) is + begin + Comp := First_Component_Or_Discriminant (R); + while Present (Comp) loop - elsif Ekind (Ent) = E_Constant - and then In_Same_Source_Unit (Ent, U_Ent) - and then Sloc (Ent) > Loc_U_Ent - then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - end if; + -- Ignore error of attribute name for component name (we + -- already gave an error message for this, so no need to + -- complain here) - return; + if Nkind (Component_Name (CC)) = N_Attribute_Reference then + null; + else + exit when Chars (Comp) = Chars (Component_Name (CC)); end if; - -- Otherwise look at the identifier and see if it is OK - - if Ekind_In (Ent, E_Named_Integer, E_Named_Real) - or else Is_Type (Ent) - then - return; + Next_Component_Or_Discriminant (Comp); + end loop; + end Search_Component; - elsif - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_In_Parameter - then - -- This is the case where we must have Ent defined before - -- U_Ent. Clearly if they are in different units this - -- requirement is met since the unit containing Ent is - -- already processed. + -- Start of processing for Find_Component - if not In_Same_Source_Unit (Ent, U_Ent) then - return; + begin + -- Return with Comp set to Empty if we have a pragma - -- Otherwise location of Ent must be before the location - -- of U_Ent, that's what prior defined means. + if Nkind (CC) = N_Pragma then + Comp := Empty; + return; + end if; - elsif Sloc (Ent) < Loc_U_Ent then - return; + -- Search current record for matching component - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_Node_2 := U_Ent; - Error_Msg_NE - ("\& must be defined before & (RM 13.1(22))!", - Nod, Ent); - end if; + Search_Component (Rectype); - elsif Nkind (Original_Node (Nod)) = N_Function_Call then - Check_Expr_Constants (Original_Node (Nod)); + -- If not found, maybe component of base type discriminant that is + -- absent from statically constrained first subtype. - else - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + if No (Comp) then + Search_Component (Base_Type (Rectype)); + end if; - if Comes_From_Source (Ent) then - Error_Msg_NE - ("\reference to variable& not allowed" - & " (RM 13.1(22))!", Nod, Ent); - else - Error_Msg_N - ("non-static expression not allowed" - & " (RM 13.1(22))!", Nod); - end if; - end if; + -- If no component, or the component does not reference the component + -- clause in question, then there was some previous error for which + -- we already gave a message, so just return with Comp Empty. - when N_Integer_Literal => + if No (Comp) or else Component_Clause (Comp) /= CC then + Check_Error_Detected; + Comp := Empty; - -- If this is a rewritten unchecked conversion, in a system - -- where Address is an integer type, always use the base type - -- for a literal value. This is user-friendly and prevents - -- order-of-elaboration issues with instances of unchecked - -- conversion. + -- Normal case where we have a component clause - if Nkind (Original_Node (Nod)) = N_Function_Call then - Set_Etype (Nod, Base_Type (Etype (Nod))); - end if; + else + Fbit := Component_Bit_Offset (Comp); + Lbit := Fbit + Esize (Comp) - 1; + end if; + end Find_Component; - when N_Real_Literal | - N_String_Literal | - N_Character_Literal => - return; + -- Start of processing for Check_Record_Representation_Clause - when N_Range => - Check_Expr_Constants (Low_Bound (Nod)); - Check_Expr_Constants (High_Bound (Nod)); + begin + Find_Type (Ident); + Rectype := Entity (Ident); - when N_Explicit_Dereference => - Check_Expr_Constants (Prefix (Nod)); + if Rectype = Any_Type then + return; + else + Rectype := Underlying_Type (Rectype); + end if; - when N_Indexed_Component => - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); + -- See if we have a fully repped derived tagged type - when N_Slice => - Check_Expr_Constants (Prefix (Nod)); - Check_Expr_Constants (Discrete_Range (Nod)); + declare + PS : constant Entity_Id := Parent_Subtype (Rectype); - when N_Selected_Component => - Check_Expr_Constants (Prefix (Nod)); + begin + if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then + Tagged_Parent := PS; - when N_Attribute_Reference => - if Nam_In (Attribute_Name (Nod), Name_Address, - Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) - then - Check_At_Constant_Address (Prefix (Nod)); + -- Find maximum bit of any component of the parent type - else - Check_Expr_Constants (Prefix (Nod)); - Check_List_Constants (Expressions (Nod)); + Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); + Pcomp := First_Entity (Tagged_Parent); + while Present (Pcomp) loop + if Ekind_In (Pcomp, E_Discriminant, E_Component) then + if Component_Bit_Offset (Pcomp) /= No_Uint + and then Known_Static_Esize (Pcomp) + then + Parent_Last_Bit := + UI_Max + (Parent_Last_Bit, + Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); + end if; + + Next_Entity (Pcomp); end if; + end loop; + end if; + end; - when N_Aggregate => - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + -- All done if no component clauses - when N_Component_Association => - Check_Expr_Constants (Expression (Nod)); + CC := First (Component_Clauses (N)); - when N_Extension_Aggregate => - Check_Expr_Constants (Ancestor_Part (Nod)); - Check_List_Constants (Component_Associations (Nod)); - Check_List_Constants (Expressions (Nod)); + if No (CC) then + return; + end if; - when N_Null => - return; + -- If a tag is present, then create a component clause that places it + -- at the start of the record (otherwise gigi may place it after other + -- fields that have rep clauses). - when N_Binary_Op | N_Short_Circuit | N_Membership_Test => - Check_Expr_Constants (Left_Opnd (Nod)); - Check_Expr_Constants (Right_Opnd (Nod)); + Fent := First_Entity (Rectype); - when N_Unary_Op => - Check_Expr_Constants (Right_Opnd (Nod)); + if Nkind (Fent) = N_Defining_Identifier + and then Chars (Fent) = Name_uTag + then + Set_Component_Bit_Offset (Fent, Uint_0); + Set_Normalized_Position (Fent, Uint_0); + Set_Normalized_First_Bit (Fent, Uint_0); + Set_Normalized_Position_Max (Fent, Uint_0); + Init_Esize (Fent, System_Address_Size); - when N_Type_Conversion | - N_Qualified_Expression | - N_Allocator | - N_Unchecked_Type_Conversion => - Check_Expr_Constants (Expression (Nod)); + Set_Component_Clause (Fent, + Make_Component_Clause (Loc, + Component_Name => Make_Identifier (Loc, Name_uTag), - when N_Function_Call => - if not Is_Pure (Entity (Name (Nod))) then - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); + Position => Make_Integer_Literal (Loc, Uint_0), + First_Bit => Make_Integer_Literal (Loc, Uint_0), + Last_Bit => + Make_Integer_Literal (Loc, + UI_From_Int (System_Address_Size)))); - Error_Msg_NE - ("\function & is not pure (RM 13.1(22))!", - Nod, Entity (Name (Nod))); + Ccount := Ccount + 1; + end if; - else - Check_List_Constants (Parameter_Associations (Nod)); - end if; + Max_Bit_So_Far := Uint_Minus_1; + Overlap_Check_Required := False; - when N_Parameter_Association => - Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); + -- Process the component clauses - when others => - Error_Msg_NE - ("invalid address clause for initialized object &!", - Nod, U_Ent); - Error_Msg_NE - ("\must be constant defined before& (RM 13.1(22))!", - Nod, U_Ent); - end case; - end Check_Expr_Constants; + while Present (CC) loop + Find_Component; - -------------------------- - -- Check_List_Constants -- - -------------------------- + if Present (Comp) then + Ccount := Ccount + 1; - procedure Check_List_Constants (Lst : List_Id) is - Nod1 : Node_Id; + -- We need a full overlap check if record positions non-monotonic - begin - if Present (Lst) then - Nod1 := First (Lst); - while Present (Nod1) loop - Check_Expr_Constants (Nod1); - Next (Nod1); - end loop; - end if; - end Check_List_Constants; + if Fbit <= Max_Bit_So_Far then + Overlap_Check_Required := True; + end if; - -- Start of processing for Check_Constant_Address_Clause + Max_Bit_So_Far := Lbit; - begin - -- If rep_clauses are to be ignored, no need for legality checks. In - -- particular, no need to pester user about rep clauses that violate - -- the rule on constant addresses, given that these clauses will be - -- removed by Freeze before they reach the back end. + -- Check bit position out of range of specified size - if not Ignore_Rep_Clauses then - Check_Expr_Constants (Expr); - end if; - end Check_Constant_Address_Clause; + if Has_Size_Clause (Rectype) + and then RM_Size (Rectype) <= Lbit + then + Error_Msg_N + ("bit number out of range of specified size", + Last_Bit (CC)); - ---------------------------------------- - -- Check_Record_Representation_Clause -- - ---------------------------------------- + -- Check for overlap with tag component - procedure Check_Record_Representation_Clause (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Ident : constant Node_Id := Identifier (N); - Rectype : Entity_Id; - Fent : Entity_Id; - CC : Node_Id; - Fbit : Uint; - Lbit : Uint; - Hbit : Uint := Uint_0; - Comp : Entity_Id; - Pcomp : Entity_Id; + else + if Is_Tagged_Type (Rectype) + and then Fbit < System_Address_Size + then + Error_Msg_NE + ("component overlaps tag field of&", + Component_Name (CC), Rectype); + Overlap_Detected := True; + end if; - Max_Bit_So_Far : Uint; - -- Records the maximum bit position so far. If all field positions - -- are monotonically increasing, then we can skip the circuit for - -- checking for overlap, since no overlap is possible. + if Hbit < Lbit then + Hbit := Lbit; + end if; + end if; - Tagged_Parent : Entity_Id := Empty; - -- This is set in the case of a derived tagged type for which we have - -- Is_Fully_Repped_Tagged_Type True (indicating that all components are - -- positioned by record representation clauses). In this case we must - -- check for overlap between components of this tagged type, and the - -- components of its parent. Tagged_Parent will point to this parent - -- type. For all other cases Tagged_Parent is left set to Empty. + -- Check parent overlap if component might overlap parent field - Parent_Last_Bit : Uint; - -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the - -- last bit position for any field in the parent type. We only need to - -- check overlap for fields starting below this point. + 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) + and then Chars (Pcomp) /= Name_uParent + then + Check_Component_Overlap (Comp, Pcomp); + end if; - Overlap_Check_Required : Boolean; - -- Used to keep track of whether or not an overlap check is required + Next_Component_Or_Discriminant (Pcomp); + end loop; + end if; + end if; - Overlap_Detected : Boolean := False; - -- Set True if an overlap is detected + Next (CC); + end loop; - Ccount : Natural := 0; - -- Number of component clauses in record rep clause + -- Now that we have processed all the component clauses, check for + -- overlap. We have to leave this till last, since the components can + -- appear in any arbitrary order in the representation clause. - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); - -- Given two entities for record components or discriminants, checks - -- if they have overlapping component clauses and issues errors if so. + -- We do not need this check if all specified ranges were monotonic, + -- as recorded by Overlap_Check_Required being False at this stage. - procedure Find_Component; - -- Finds component entity corresponding to current component clause (in - -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin - -- start/stop bits for the field. If there is no matching component or - -- if the matching component does not have a component clause, then - -- that's an error and Comp is set to Empty, but no error message is - -- issued, since the message was already given. Comp is also set to - -- Empty if the current "component clause" is in fact a pragma. + -- This first section checks if there are any overlapping entries at + -- all. It does this by sorting all entries and then seeing if there are + -- any overlaps. If there are none, then that is decisive, but if there + -- are overlaps, they may still be OK (they may result from fields in + -- different variants). - ----------------------------- - -- Check_Component_Overlap -- - ----------------------------- + if Overlap_Check_Required then + Overlap_Check1 : declare - procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is - CC1 : constant Node_Id := Component_Clause (C1_Ent); - CC2 : constant Node_Id := Component_Clause (C2_Ent); + OC_Fbit : array (0 .. Ccount) of Uint; + -- First-bit values for component clauses, the value is the offset + -- of the first bit of the field from start of record. The zero + -- entry is for use in sorting. - begin - if Present (CC1) and then Present (CC2) then + OC_Lbit : array (0 .. Ccount) of Uint; + -- Last-bit values for component clauses, the value is the offset + -- of the last bit of the field from start of record. The zero + -- entry is for use in sorting. + + OC_Count : Natural := 0; + -- Count of entries in OC_Fbit and OC_Lbit - -- 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. + function OC_Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then - return; - end if; + procedure OC_Move (From : Natural; To : Natural); + -- Move routine for Sort - -- Here we check if the two fields overlap + package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); - declare - S1 : constant Uint := Component_Bit_Offset (C1_Ent); - S2 : constant Uint := Component_Bit_Offset (C2_Ent); - E1 : constant Uint := S1 + Esize (C1_Ent); - E2 : constant Uint := S2 + Esize (C2_Ent); + ----------- + -- OC_Lt -- + ----------- + function OC_Lt (Op1, Op2 : Natural) return Boolean is begin - if E2 <= S1 or else E1 <= S2 then - null; - else - Error_Msg_Node_2 := Component_Name (CC2); - Error_Msg_Sloc := Sloc (Error_Msg_Node_2); - Error_Msg_Node_1 := Component_Name (CC1); - Error_Msg_N - ("component& overlaps & #", Component_Name (CC1)); - Overlap_Detected := True; - end if; - end; - end if; - end Check_Component_Overlap; - - -------------------- - -- Find_Component -- - -------------------- + return OC_Fbit (Op1) < OC_Fbit (Op2); + end OC_Lt; - procedure Find_Component is + ------------- + -- OC_Move -- + ------------- - procedure Search_Component (R : Entity_Id); - -- Search components of R for a match. If found, Comp is set + procedure OC_Move (From : Natural; To : Natural) is + begin + OC_Fbit (To) := OC_Fbit (From); + OC_Lbit (To) := OC_Lbit (From); + end OC_Move; - ---------------------- - -- Search_Component -- - ---------------------- + -- Start of processing for Overlap_Check - procedure Search_Component (R : Entity_Id) is begin - Comp := First_Component_Or_Discriminant (R); - while Present (Comp) loop + CC := First (Component_Clauses (N)); + while Present (CC) loop - -- Ignore error of attribute name for component name (we - -- already gave an error message for this, so no need to - -- complain here) + -- Exclude component clause already marked in error - if Nkind (Component_Name (CC)) = N_Attribute_Reference then - null; - else - exit when Chars (Comp) = Chars (Component_Name (CC)); + if not Error_Posted (CC) then + Find_Component; + + if Present (Comp) then + OC_Count := OC_Count + 1; + OC_Fbit (OC_Count) := Fbit; + OC_Lbit (OC_Count) := Lbit; + end if; end if; - Next_Component_Or_Discriminant (Comp); + Next (CC); end loop; - end Search_Component; - -- Start of processing for Find_Component - - begin - -- Return with Comp set to Empty if we have a pragma + Sorting.Sort (OC_Count); - if Nkind (CC) = N_Pragma then - Comp := Empty; - return; - end if; + Overlap_Check_Required := False; + for J in 1 .. OC_Count - 1 loop + if OC_Lbit (J) >= OC_Fbit (J + 1) then + Overlap_Check_Required := True; + exit; + end if; + end loop; + end Overlap_Check1; + end if; - -- Search current record for matching component + -- If Overlap_Check_Required is still True, then we have to do the full + -- scale overlap check, since we have at least two fields that do + -- overlap, and we need to know if that is OK since they are in + -- different variant, or whether we have a definite problem. - Search_Component (Rectype); + if Overlap_Check_Required then + Overlap_Check2 : declare + C1_Ent, C2_Ent : Entity_Id; + -- Entities of components being checked for overlap - -- If not found, maybe component of base type discriminant that is - -- absent from statically constrained first subtype. + Clist : Node_Id; + -- Component_List node whose Component_Items are being checked - if No (Comp) then - Search_Component (Base_Type (Rectype)); - end if; + Citem : Node_Id; + -- Component declaration for component being checked - -- If no component, or the component does not reference the component - -- clause in question, then there was some previous error for which - -- we already gave a message, so just return with Comp Empty. + begin + C1_Ent := First_Entity (Base_Type (Rectype)); - if No (Comp) or else Component_Clause (Comp) /= CC then - Check_Error_Detected; - Comp := Empty; + -- Loop through all components in record. For each component check + -- for overlap with any of the preceding elements on the component + -- list containing the component and also, if the component is in + -- a variant, check against components outside the case structure. + -- This latter test is repeated recursively up the variant tree. - -- Normal case where we have a component clause + Main_Component_Loop : while Present (C1_Ent) loop + if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then + goto Continue_Main_Component_Loop; + end if; - else - Fbit := Component_Bit_Offset (Comp); - Lbit := Fbit + Esize (Comp) - 1; - end if; - end Find_Component; + -- Skip overlap check if entity has no declaration node. This + -- happens with discriminants in constrained derived types. + -- Possibly we are missing some checks as a result, but that + -- does not seem terribly serious. - -- Start of processing for Check_Record_Representation_Clause + if No (Declaration_Node (C1_Ent)) then + goto Continue_Main_Component_Loop; + end if; - begin - Find_Type (Ident); - Rectype := Entity (Ident); + Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); - if Rectype = Any_Type then - return; - else - Rectype := Underlying_Type (Rectype); - end if; + -- Loop through component lists that need checking. Check the + -- current component list and all lists in variants above us. - -- See if we have a fully repped derived tagged type + Component_List_Loop : loop - declare - PS : constant Entity_Id := Parent_Subtype (Rectype); + -- If derived type definition, go to full declaration + -- If at outer level, check discriminants if there are any. - begin - if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then - Tagged_Parent := PS; + if Nkind (Clist) = N_Derived_Type_Definition then + Clist := Parent (Clist); + end if; - -- Find maximum bit of any component of the parent type + -- Outer level of record definition, check discriminants - Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); - Pcomp := First_Entity (Tagged_Parent); - while Present (Pcomp) loop - if Ekind_In (Pcomp, E_Discriminant, E_Component) then - if Component_Bit_Offset (Pcomp) /= No_Uint - and then Known_Static_Esize (Pcomp) + if Nkind_In (Clist, N_Full_Type_Declaration, + N_Private_Type_Declaration) then - Parent_Last_Bit := - UI_Max - (Parent_Last_Bit, - Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); - end if; + if Has_Discriminants (Defining_Identifier (Clist)) then + C2_Ent := + First_Discriminant (Defining_Identifier (Clist)); + while Present (C2_Ent) loop + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + Next_Discriminant (C2_Ent); + end loop; + end if; - Next_Entity (Pcomp); - end if; - end loop; - end if; - end; + -- Record extension case - -- All done if no component clauses + elsif Nkind (Clist) = N_Derived_Type_Definition then + Clist := Empty; - CC := First (Component_Clauses (N)); + -- Otherwise check one component list - if No (CC) then - return; - end if; + else + Citem := First (Component_Items (Clist)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + C2_Ent := Defining_Identifier (Citem); + exit when C1_Ent = C2_Ent; + Check_Component_Overlap (C1_Ent, C2_Ent); + end if; - -- If a tag is present, then create a component clause that places it - -- at the start of the record (otherwise gigi may place it after other - -- fields that have rep clauses). + Next (Citem); + end loop; + end if; - Fent := First_Entity (Rectype); + -- Check for variants above us (the parent of the Clist can + -- be a variant, in which case its parent is a variant part, + -- and the parent of the variant part is a component list + -- whose components must all be checked against the current + -- component for overlap). - if Nkind (Fent) = N_Defining_Identifier - and then Chars (Fent) = Name_uTag - then - Set_Component_Bit_Offset (Fent, Uint_0); - Set_Normalized_Position (Fent, Uint_0); - Set_Normalized_First_Bit (Fent, Uint_0); - Set_Normalized_Position_Max (Fent, Uint_0); - Init_Esize (Fent, System_Address_Size); + if Nkind (Parent (Clist)) = N_Variant then + Clist := Parent (Parent (Parent (Clist))); - Set_Component_Clause (Fent, - Make_Component_Clause (Loc, - Component_Name => Make_Identifier (Loc, Name_uTag), + -- Check for possible discriminant part in record, this + -- is treated essentially as another level in the + -- recursion. For this case the parent of the component + -- list is the record definition, and its parent is the + -- full type declaration containing the discriminant + -- specifications. + + elsif Nkind (Parent (Clist)) = N_Record_Definition then + Clist := Parent (Parent ((Clist))); + + -- If neither of these two cases, we are at the top of + -- the tree. + + else + exit Component_List_Loop; + end if; + end loop Component_List_Loop; - Position => Make_Integer_Literal (Loc, Uint_0), - First_Bit => Make_Integer_Literal (Loc, Uint_0), - Last_Bit => - Make_Integer_Literal (Loc, - UI_From_Int (System_Address_Size)))); + <> + Next_Entity (C1_Ent); - Ccount := Ccount + 1; + end loop Main_Component_Loop; + end Overlap_Check2; end if; - Max_Bit_So_Far := Uint_Minus_1; - Overlap_Check_Required := False; - - -- Process the component clauses + -- The following circuit deals with warning on record holes (gaps). We + -- skip this check if overlap was detected, since it makes sense for the + -- programmer to fix this illegality before worrying about warnings. - while Present (CC) loop - Find_Component; + if not Overlap_Detected and Warn_On_Record_Holes then + Record_Hole_Check : declare + Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); + -- Full declaration of record type - if Present (Comp) then - Ccount := Ccount + 1; + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id); + -- Check component list CL for holes. The starting bit should be + -- Sbit. which is zero for the main record component list and set + -- appropriately for recursive calls for variants. DS is set to + -- a list of discriminant specifications to be included in the + -- consideration of components. It is No_List if none to consider. - -- We need a full overlap check if record positions non-monotonic + -------------------------- + -- Check_Component_List -- + -------------------------- - if Fbit <= Max_Bit_So_Far then - Overlap_Check_Required := True; - end if; + procedure Check_Component_List + (CL : Node_Id; + Sbit : Uint; + DS : List_Id) + is + Compl : Integer; - Max_Bit_So_Far := Lbit; + begin + Compl := Integer (List_Length (Component_Items (CL))); - -- Check bit position out of range of specified size + if DS /= No_List then + Compl := Compl + Integer (List_Length (DS)); + end if; - if Has_Size_Clause (Rectype) - and then RM_Size (Rectype) <= Lbit - then - Error_Msg_N - ("bit number out of range of specified size", - Last_Bit (CC)); + declare + Comps : array (Natural range 0 .. Compl) of Entity_Id; + -- Gather components (zero entry is for sort routine) - -- Check for overlap with tag component + Ncomps : Natural := 0; + -- Number of entries stored in Comps (starting at Comps (1)) - else - if Is_Tagged_Type (Rectype) - and then Fbit < System_Address_Size - then - Error_Msg_NE - ("component overlaps tag field of&", - Component_Name (CC), Rectype); - Overlap_Detected := True; - end if; + Citem : Node_Id; + -- One component item or discriminant specification - if Hbit < Lbit then - Hbit := Lbit; - end if; - end if; + Nbit : Uint; + -- Starting bit for next component - -- Check parent overlap if component might overlap parent field + CEnt : Entity_Id; + -- Component entity - 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) - and then Chars (Pcomp) /= Name_uParent - then - Check_Component_Overlap (Comp, Pcomp); - end if; + Variant : Node_Id; + -- One variant - Next_Component_Or_Discriminant (Pcomp); - end loop; - end if; - end if; + function Lt (Op1, Op2 : Natural) return Boolean; + -- Compare routine for Sort - Next (CC); - end loop; + procedure Move (From : Natural; To : Natural); + -- Move routine for Sort - -- Now that we have processed all the component clauses, check for - -- overlap. We have to leave this till last, since the components can - -- appear in any arbitrary order in the representation clause. + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - -- We do not need this check if all specified ranges were monotonic, - -- as recorded by Overlap_Check_Required being False at this stage. + -------- + -- Lt -- + -------- - -- This first section checks if there are any overlapping entries at - -- all. It does this by sorting all entries and then seeing if there are - -- any overlaps. If there are none, then that is decisive, but if there - -- are overlaps, they may still be OK (they may result from fields in - -- different variants). + function Lt (Op1, Op2 : Natural) return Boolean is + begin + return Component_Bit_Offset (Comps (Op1)) + < + Component_Bit_Offset (Comps (Op2)); + end Lt; - if Overlap_Check_Required then - Overlap_Check1 : declare + ---------- + -- Move -- + ---------- - OC_Fbit : array (0 .. Ccount) of Uint; - -- First-bit values for component clauses, the value is the offset - -- of the first bit of the field from start of record. The zero - -- entry is for use in sorting. + procedure Move (From : Natural; To : Natural) is + begin + Comps (To) := Comps (From); + end Move; - OC_Lbit : array (0 .. Ccount) of Uint; - -- Last-bit values for component clauses, the value is the offset - -- of the last bit of the field from start of record. The zero - -- entry is for use in sorting. + begin + -- Gather discriminants into Comp - OC_Count : Natural := 0; - -- Count of entries in OC_Fbit and OC_Lbit + if DS /= No_List then + Citem := First (DS); + while Present (Citem) loop + if Nkind (Citem) = N_Discriminant_Specification then + declare + Ent : constant Entity_Id := + Defining_Identifier (Citem); + begin + if Ekind (Ent) = E_Discriminant then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Ent; + end if; + end; + end if; - function OC_Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + Next (Citem); + end loop; + end if; - procedure OC_Move (From : Natural; To : Natural); - -- Move routine for Sort + -- Gather component entities into Comp - package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); + Citem := First (Component_Items (CL)); + while Present (Citem) loop + if Nkind (Citem) = N_Component_Declaration then + Ncomps := Ncomps + 1; + Comps (Ncomps) := Defining_Identifier (Citem); + end if; - ----------- - -- OC_Lt -- - ----------- + Next (Citem); + end loop; - function OC_Lt (Op1, Op2 : Natural) return Boolean is - begin - return OC_Fbit (Op1) < OC_Fbit (Op2); - end OC_Lt; + -- Now sort the component entities based on the first bit. + -- Note we already know there are no overlapping components. - ------------- - -- OC_Move -- - ------------- + Sorting.Sort (Ncomps); - procedure OC_Move (From : Natural; To : Natural) is - begin - OC_Fbit (To) := OC_Fbit (From); - OC_Lbit (To) := OC_Lbit (From); - end OC_Move; + -- Loop through entries checking for holes - -- Start of processing for Overlap_Check + Nbit := Sbit; + for J in 1 .. Ncomps loop + CEnt := Comps (J); + Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; - begin - CC := First (Component_Clauses (N)); - while Present (CC) loop + if Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?H?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), CEnt); + end if; - -- Exclude component clause already marked in error + Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); + end loop; - if not Error_Posted (CC) then - Find_Component; + -- Process variant parts recursively if present - if Present (Comp) then - OC_Count := OC_Count + 1; - OC_Fbit (OC_Count) := Fbit; - OC_Lbit (OC_Count) := Lbit; + if Present (Variant_Part (CL)) then + Variant := First (Variants (Variant_Part (CL))); + while Present (Variant) loop + Check_Component_List + (Component_List (Variant), Nbit, No_List); + Next (Variant); + end loop; end if; - end if; + end; + end Check_Component_List; - Next (CC); - end loop; + -- Start of processing for Record_Hole_Check - Sorting.Sort (OC_Count); + begin + declare + Sbit : Uint; - Overlap_Check_Required := False; - for J in 1 .. OC_Count - 1 loop - if OC_Lbit (J) >= OC_Fbit (J + 1) then - Overlap_Check_Required := True; - exit; + begin + if Is_Tagged_Type (Rectype) then + Sbit := UI_From_Int (System_Address_Size); + else + Sbit := Uint_0; + end if; + + if Nkind (Decl) = N_Full_Type_Declaration + and then Nkind (Type_Definition (Decl)) = N_Record_Definition + then + Check_Component_List + (Component_List (Type_Definition (Decl)), + Sbit, + Discriminant_Specifications (Decl)); end if; - end loop; - end Overlap_Check1; + end; + end Record_Hole_Check; end if; - -- If Overlap_Check_Required is still True, then we have to do the full - -- scale overlap check, since we have at least two fields that do - -- overlap, and we need to know if that is OK since they are in - -- different variant, or whether we have a definite problem. + -- For records that have component clauses for all components, and whose + -- size is less than or equal to 32, we need to know the size in the + -- front end to activate possible packed array processing where the + -- component type is a record. - if Overlap_Check_Required then - Overlap_Check2 : declare - C1_Ent, C2_Ent : Entity_Id; - -- Entities of components being checked for overlap + -- At this stage Hbit + 1 represents the first unused bit from all the + -- component clauses processed, so if the component clauses are + -- complete, then this is the length of the record. - Clist : Node_Id; - -- Component_List node whose Component_Items are being checked + -- For records longer than System.Storage_Unit, and for those where not + -- all components have component clauses, the back end determines the + -- length (it may for example be appropriate to round up the size + -- to some convenient boundary, based on alignment considerations, etc). - Citem : Node_Id; - -- Component declaration for component being checked + if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then - begin - C1_Ent := First_Entity (Base_Type (Rectype)); + -- Nothing to do if at least one component has no component clause - -- Loop through all components in record. For each component check - -- for overlap with any of the preceding elements on the component - -- list containing the component and also, if the component is in - -- a variant, check against components outside the case structure. - -- This latter test is repeated recursively up the variant tree. + Comp := First_Component_Or_Discriminant (Rectype); + while Present (Comp) loop + exit when No (Component_Clause (Comp)); + Next_Component_Or_Discriminant (Comp); + end loop; - Main_Component_Loop : while Present (C1_Ent) loop - if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then - goto Continue_Main_Component_Loop; - end if; + -- If we fall out of loop, all components have component clauses + -- and so we can set the size to the maximum value. - -- Skip overlap check if entity has no declaration node. This - -- happens with discriminants in constrained derived types. - -- Possibly we are missing some checks as a result, but that - -- does not seem terribly serious. + if No (Comp) then + Set_RM_Size (Rectype, Hbit + 1); + end if; + end if; + end Check_Record_Representation_Clause; - if No (Declaration_Node (C1_Ent)) then - goto Continue_Main_Component_Loop; - end if; + ---------------- + -- Check_Size -- + ---------------- - Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); + procedure Check_Size + (N : Node_Id; + T : Entity_Id; + Siz : Uint; + Biased : out Boolean) + is + UT : constant Entity_Id := Underlying_Type (T); + M : Uint; - -- Loop through component lists that need checking. Check the - -- current component list and all lists in variants above us. + begin + Biased := False; - Component_List_Loop : loop + -- Reject patently improper size values. - -- If derived type definition, go to full declaration - -- If at outer level, check discriminants if there are any. + if Is_Elementary_Type (T) + and then Siz > UI_From_Int (Int'Last) + then + Error_Msg_N ("Size value too large for elementary type", N); - if Nkind (Clist) = N_Derived_Type_Definition then - Clist := Parent (Clist); - end if; + if Nkind (Original_Node (N)) = N_Op_Expon then + Error_Msg_N + ("\maybe '* was meant, rather than '*'*", Original_Node (N)); + end if; + end if; - -- Outer level of record definition, check discriminants + -- Dismiss generic types - if Nkind_In (Clist, N_Full_Type_Declaration, - N_Private_Type_Declaration) - then - if Has_Discriminants (Defining_Identifier (Clist)) then - C2_Ent := - First_Discriminant (Defining_Identifier (Clist)); - while Present (C2_Ent) loop - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - Next_Discriminant (C2_Ent); - end loop; - end if; + if Is_Generic_Type (T) + or else + Is_Generic_Type (UT) + or else + Is_Generic_Type (Root_Type (UT)) + then + return; - -- Record extension case + -- Guard against previous errors - elsif Nkind (Clist) = N_Derived_Type_Definition then - Clist := Empty; + elsif No (UT) or else UT = Any_Type then + Check_Error_Detected; + return; - -- Otherwise check one component list + -- Check case of bit packed array - else - Citem := First (Component_Items (Clist)); - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - C2_Ent := Defining_Identifier (Citem); - exit when C1_Ent = C2_Ent; - Check_Component_Overlap (C1_Ent, C2_Ent); - end if; + elsif Is_Array_Type (UT) + and then Known_Static_Component_Size (UT) + and then Is_Bit_Packed_Array (UT) + then + declare + Asiz : Uint; + Indx : Node_Id; + Ityp : Entity_Id; - Next (Citem); - end loop; - end if; + begin + Asiz := Component_Size (UT); + Indx := First_Index (UT); + loop + Ityp := Etype (Indx); - -- Check for variants above us (the parent of the Clist can - -- be a variant, in which case its parent is a variant part, - -- and the parent of the variant part is a component list - -- whose components must all be checked against the current - -- component for overlap). + -- If non-static bound, then we are not in the business of + -- trying to check the length, and indeed an error will be + -- issued elsewhere, since sizes of non-static array types + -- cannot be set implicitly or explicitly. - if Nkind (Parent (Clist)) = N_Variant then - Clist := Parent (Parent (Parent (Clist))); + if not Is_Static_Subtype (Ityp) then + return; + end if; - -- Check for possible discriminant part in record, this - -- is treated essentially as another level in the - -- recursion. For this case the parent of the component - -- list is the record definition, and its parent is the - -- full type declaration containing the discriminant - -- specifications. + -- Otherwise accumulate next dimension - elsif Nkind (Parent (Clist)) = N_Record_Definition then - Clist := Parent (Parent ((Clist))); + Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - + Expr_Value (Type_Low_Bound (Ityp)) + + Uint_1); - -- If neither of these two cases, we are at the top of - -- the tree. + Next_Index (Indx); + exit when No (Indx); + end loop; - else - exit Component_List_Loop; - end if; - end loop Component_List_Loop; + if Asiz <= Siz then + return; - <> - Next_Entity (C1_Ent); + else + Error_Msg_Uint_1 := Asiz; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, Asiz); + Set_RM_Size (T, Asiz); + end if; + end; - end loop Main_Component_Loop; - end Overlap_Check2; - end if; + -- All other composite types are ignored - -- The following circuit deals with warning on record holes (gaps). We - -- skip this check if overlap was detected, since it makes sense for the - -- programmer to fix this illegality before worrying about warnings. + elsif Is_Composite_Type (UT) then + return; - if not Overlap_Detected and Warn_On_Record_Holes then - Record_Hole_Check : declare - Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); - -- Full declaration of record type + -- For fixed-point types, don't check minimum if type is not frozen, + -- since we don't know all the characteristics of the type that can + -- affect the size (e.g. a specified small) till freeze time. - procedure Check_Component_List - (CL : Node_Id; - Sbit : Uint; - DS : List_Id); - -- Check component list CL for holes. The starting bit should be - -- Sbit. which is zero for the main record component list and set - -- appropriately for recursive calls for variants. DS is set to - -- a list of discriminant specifications to be included in the - -- consideration of components. It is No_List if none to consider. + elsif Is_Fixed_Point_Type (UT) + and then not Is_Frozen (UT) + then + null; - -------------------------- - -- Check_Component_List -- - -------------------------- + -- Cases for which a minimum check is required - procedure Check_Component_List - (CL : Node_Id; - Sbit : Uint; - DS : List_Id) - is - Compl : Integer; + else + -- Ignore if specified size is correct for the type - begin - Compl := Integer (List_Length (Component_Items (CL))); + if Known_Esize (UT) and then Siz = Esize (UT) then + return; + end if; - if DS /= No_List then - Compl := Compl + Integer (List_Length (DS)); - end if; + -- Otherwise get minimum size - declare - Comps : array (Natural range 0 .. Compl) of Entity_Id; - -- Gather components (zero entry is for sort routine) + M := UI_From_Int (Minimum_Size (UT)); - Ncomps : Natural := 0; - -- Number of entries stored in Comps (starting at Comps (1)) + if Siz < M then - Citem : Node_Id; - -- One component item or discriminant specification + -- Size is less than minimum size, but one possibility remains + -- that we can manage with the new size if we bias the type. - Nbit : Uint; - -- Starting bit for next component + M := UI_From_Int (Minimum_Size (UT, Biased => True)); - CEnt : Entity_Id; - -- Component entity + if Siz < M then + Error_Msg_Uint_1 := M; + Error_Msg_NE + ("size for& too small, minimum allowed is ^", N, T); + Set_Esize (T, M); + Set_RM_Size (T, M); + else + Biased := True; + end if; + end if; + end if; + end Check_Size; - Variant : Node_Id; - -- One variant + -------------------------- + -- Freeze_Entity_Checks -- + -------------------------- - function Lt (Op1, Op2 : Natural) return Boolean; - -- Compare routine for Sort + procedure Freeze_Entity_Checks (N : Node_Id) is + E : constant Entity_Id := Entity (N); - procedure Move (From : Natural; To : Natural); - -- Move routine for Sort + 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). - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; - -------- - -- Lt -- - -------- + -- 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). - function Lt (Op1, Op2 : Natural) return Boolean is - begin - return Component_Bit_Offset (Comps (Op1)) - < - Component_Bit_Offset (Comps (Op2)); - end Lt; + -- This is not needed in the generic case - ---------- - -- Move -- - ---------- + 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. - procedure Move (From : Natural; To : Natural) is - begin - Comps (To) := Comps (From); - end Move; + Add_Internal_Interface_Entities (E); + end if; - begin - -- Gather discriminants into Comp + -- Check CPP types - if DS /= No_List then - Citem := First (DS); - while Present (Citem) loop - if Nkind (Citem) = N_Discriminant_Specification then - declare - Ent : constant Entity_Id := - Defining_Identifier (Citem); - begin - if Ekind (Ent) = E_Discriminant then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Ent; - end if; - end; - end if; + 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 -- why? losing errors in -gnatc mode??? + then + if CPP_Num_Prims (E) = 0 then - Next (Citem); - end loop; - end if; + -- 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. - -- Gather component entities into Comp + pragma Assert (Chars (First_Entity (E)) = Name_uTag); - Citem := First (Component_Items (CL)); - while Present (Citem) loop - if Nkind (Citem) = N_Component_Declaration then - Ncomps := Ncomps + 1; - Comps (Ncomps) := Defining_Identifier (Citem); - end if; + 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; - Next (Citem); - end loop; + -- Check that all its primitives are abstract or imported from C++. + -- Check also availability of the C++ constructor. - -- Now sort the component entities based on the first bit. - -- Note we already know there are no overlapping components. + declare + Has_Constructors : constant Boolean := Has_CPP_Constructors (E); + Elmt : Elmt_Id; + Error_Reported : Boolean := False; + Prim : Node_Id; - Sorting.Sort (Ncomps); + begin + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); - -- Loop through entries checking for holes + if Comes_From_Source (Prim) then + if Is_Abstract_Subprogram (Prim) then + null; - Nbit := Sbit; - for J in 1 .. Ncomps loop - CEnt := Comps (J); - Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; + 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); - if Error_Msg_Uint_1 > 0 then - Error_Msg_NE - ("?H?^-bit gap before component&", - Component_Name (Component_Clause (CEnt)), CEnt); - end if; + 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; - Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); - end loop; + Next_Elmt (Elmt); + end loop; + end; + end if; - -- Process variant parts recursively if present + -- Check Ada derivation of CPP type - if Present (Variant_Part (CL)) then - Variant := First (Variants (Variant_Part (CL))); - while Present (Variant) loop - Check_Component_List - (Component_List (Variant), Nbit, No_List); - Next (Variant); - end loop; - end if; - end; - end Check_Component_List; + 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. - -- Start of processing for Record_Hole_Check + declare + Elmt : Elmt_Id; + Prim : Node_Id; begin - declare - Sbit : Uint; - - begin - if Is_Tagged_Type (Rectype) then - Sbit := UI_From_Int (System_Address_Size); - else - Sbit := Uint_0; - end if; + Elmt := First_Elmt (Primitive_Operations (E)); + while Present (Elmt) loop + Prim := Node (Elmt); - if Nkind (Decl) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Decl)) = N_Record_Definition + if not Is_Abstract_Subprogram (Prim) + and then No (Interface_Alias (Prim)) + and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E then - Check_Component_List - (Component_List (Type_Definition (Decl)), - Sbit, - Discriminant_Specifications (Decl)); + Error_Msg_Name_1 := Chars (Etype (E)); + Error_Msg_N + ("'C'P'P constructor required for parent type %", E); + exit; end if; - end; - end Record_Hole_Check; + + Next_Elmt (Elmt); + end loop; + end; end if; - -- For records that have component clauses for all components, and whose - -- size is less than or equal to 32, we need to know the size in the - -- front end to activate possible packed array processing where the - -- component type is a record. + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; - -- At this stage Hbit + 1 represents the first unused bit from all the - -- component clauses processed, so if the component clauses are - -- complete, then this is the length of the record. + -- If we have a type with predicates, build predicate function. This + -- is not needed in the generic casee - -- For records longer than System.Storage_Unit, and for those where not - -- all components have component clauses, the back end determines the - -- length (it may for example be appropriate to round up the size - -- to some convenient boundary, based on alignment considerations, etc). + if Non_Generic_Case and then Is_Type (E) and then Has_Predicates (E) then + Build_Predicate_Functions (E, N); + end if; - if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then + -- 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. - -- Nothing to do if at least one component has no component clause + -- 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 - Comp := First_Component_Or_Discriminant (Rectype); - while Present (Comp) loop - exit when No (Component_Clause (Comp)); - Next_Component_Or_Discriminant (Comp); - end loop; + 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; - -- If we fall out of loop, all components have component clauses - -- and so we can set the size to the maximum value. + Next_Rep_Item (Ritem); + end loop; + end; - if No (Comp) then - Set_RM_Size (Rectype, Hbit + 1); - end if; + Uninstall_Discriminants_And_Pop_Scope (E); end if; - end Check_Record_Representation_Clause; - ---------------- - -- Check_Size -- - ---------------- + -- 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. - procedure Check_Size - (N : Node_Id; - T : Entity_Id; - Siz : Uint; - Biased : out Boolean) - is - UT : constant Entity_Id := Underlying_Type (T); - M : Uint; + 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; - begin - Biased := False; + Others_Present : Boolean; + pragma Warnings (Off, Others_Present); + -- Indicates others present, not used in this case - -- Reject patently improper size values. + 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. - if Is_Elementary_Type (T) - and then Siz > UI_From_Int (Int'Last) - then - Error_Msg_N ("Size value too large for elementary type", N); + 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. - if Nkind (Original_Node (N)) = N_Op_Expon then - Error_Msg_N - ("\maybe '* was meant, rather than '*'*", Original_Node (N)); - end if; - end if; + 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; - -- Dismiss generic types + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- - if Is_Generic_Type (T) - or else - Is_Generic_Type (UT) - or else - Is_Generic_Type (Root_Type (UT)) - then - return; + 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; - -- Guard against previous errors + -------------------------- + -- Process_Declarations -- + -------------------------- - elsif No (UT) or else UT = Any_Type then - Check_Error_Detected; - return; + procedure Process_Declarations (Variant : Node_Id) is + CL : constant Node_Id := Component_List (Variant); + VP : Node_Id; - -- Check case of bit packed array + begin + -- Check for static predicate present in this variant - elsif Is_Array_Type (UT) - and then Known_Static_Component_Size (UT) - and then Is_Bit_Packed_Array (UT) - then - declare - Asiz : Uint; - Indx : Node_Id; - Ityp : Entity_Id; + if Has_SP_Choice (Variant) then - begin - Asiz := Component_Size (UT); - Indx := First_Index (UT); - loop - Ityp := Etype (Indx); + -- 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. - -- If non-static bound, then we are not in the business of - -- trying to check the length, and indeed an error will be - -- issued elsewhere, since sizes of non-static array types - -- cannot be set implicitly or explicitly. + -- 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 not Is_Static_Subtype (Ityp) then - return; + -- 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; - -- Otherwise accumulate next dimension + -- 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. - Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - - Expr_Value (Type_Low_Bound (Ityp)) + - Uint_1); + if not Null_Present (CL) then + VP := Variant_Part (CL); - Next_Index (Indx); - exit when No (Indx); - end loop; + if Present (VP) then + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + end if; + end if; + end Process_Declarations; - if Asiz <= Siz then - return; + -- Start of processing for Check_Variant_Part - else - Error_Msg_Uint_1 := Asiz; - Error_Msg_NE - ("size for& too small, minimum allowed is ^", N, T); - Set_Esize (T, Asiz); - Set_RM_Size (T, Asiz); - end if; - end; + begin + -- Find component list - -- All other composite types are ignored + C := Empty; - elsif Is_Composite_Type (UT) then - return; + if Nkind (D) = N_Full_Type_Declaration then + T := Type_Definition (D); - -- For fixed-point types, don't check minimum if type is not frozen, - -- since we don't know all the characteristics of the type that can - -- affect the size (e.g. a specified small) till freeze time. + if Nkind (T) = N_Record_Definition then + C := Component_List (T); - elsif Is_Fixed_Point_Type (UT) - and then not Is_Frozen (UT) - then - null; + 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; - -- Cases for which a minimum check is required + -- Case of variant part present - else - -- Ignore if specified size is correct for the type + if Present (C) and then Present (Variant_Part (C)) then + VP := Variant_Part (C); - if Known_Esize (UT) and then Siz = Esize (UT) then - return; - end if; + -- Check choices - -- Otherwise get minimum size + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); - M := UI_From_Int (Minimum_Size (UT)); + -- 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!) - if Siz < M then + -- We only want to do this if the expander is active, since + -- we do not want to clobber the ASIS tree! - -- Size is less than minimum size, but one possibility remains - -- that we can manage with the new size if we bias the type. + if Expander_Active then + declare + Last_Var : constant Node_Id := + Last_Non_Pragma (Variants (VP)); - M := UI_From_Int (Minimum_Size (UT, Biased => True)); + Others_Node : Node_Id; - if Siz < M then - Error_Msg_Uint_1 := M; - Error_Msg_NE - ("size for& too small, minimum allowed is ^", N, T); - Set_Esize (T, M); - Set_RM_Size (T, M); - else - Biased := True; + 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 if; + end Check_Variant_Part; end if; - end Check_Size; + end Freeze_Entity_Checks; ------------------------- -- Get_Alignment_Value -- diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0ee2c56..6bf34ef 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -7336,6 +7336,8 @@ package Sinfo is -- trigger these checks. The Freeze_Generic_Entity node plays no other -- role, and is ignored by the expander and the back-end. + -- Sprint syntax: freeze_generic entity-name + -- N_Freeze_Generic_Entity -- Sloc points near freeze point -- Entity (Node4-Sem) diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 173d148..72fde2f 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -57,6 +57,7 @@ package Sprint is -- Expression with range check {expression} -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] + -- Freeze generic entity freeze_generic entityname -- Implicit call to run time routine $routine-name -- Implicit exportation $pragma import (...) -- Implicit importation $pragma export (...) -- 2.7.4