-- 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
---------------------------
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
-- 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
-- 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))));
+ <<Continue_Main_Component_Loop>>
+ 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;
- <<Continue_Main_Component_Loop>>
- 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 --
projects / thirdparty / gcc.git / commitdiff
