-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
----------------------------------------------
-- The following table collects unchecked conversions for validation.
- -- Entries are made by Validate_Unchecked_Conversion and then the
- -- call to Validate_Unchecked_Conversions does the actual error
- -- checking and posting of warnings. The reason for this delayed
- -- processing is to take advantage of back-annotations of size and
- -- alignment values performed by the back end.
+ -- Entries are made by Validate_Unchecked_Conversion and then the call
+ -- to Validate_Unchecked_Conversions does the actual error checking and
+ -- posting of warnings. The reason for this delayed processing is to take
+ -- advantage of back-annotations of size and alignment values performed by
+ -- the back end.
- -- Note: the reason we store a Source_Ptr value instead of a Node_Id
- -- is that by the time Validate_Unchecked_Conversions is called, Sprint
- -- will already have modified all Sloc values if the -gnatD option is set.
+ -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
+ -- that by the time Validate_Unchecked_Conversions is called, Sprint will
+ -- already have modified all Sloc values if the -gnatD option is set.
type UC_Entry is record
Eloc : Source_Ptr; -- node used for posting warnings
-- for X'Address use Expr
- -- where Expr is of the form Y'Address or recursively is a reference
- -- to a constant of either of these forms, and X and Y are entities of
- -- objects, then if Y has a smaller alignment than X, that merits a
- -- warning about possible bad alignment. The following table collects
- -- address clauses of this kind. We put these in a table so that they
- -- can be checked after the back end has completed annotation of the
- -- alignments of objects, since we can catch more cases that way.
+ -- where Expr is of the form Y'Address or recursively is a reference to a
+ -- constant of either of these forms, and X and Y are entities of objects,
+ -- then if Y has a smaller alignment than X, that merits a warning about
+ -- possible bad alignment. The following table collects address clauses of
+ -- this kind. We put these in a table so that they can be checked after the
+ -- back end has completed annotation of the alignments of objects, since we
+ -- can catch more cases that way.
type Address_Clause_Check_Record is record
N : Node_Id;
end loop;
end if;
+ -- Check some general restrictions on language defined aspects
+
+ if not Impl_Defined_Aspects (A_Id) then
+ Error_Msg_Name_1 := Nam;
+
+ -- Not allowed for renaming declarations
+
+ if Nkind (N) in N_Renaming_Declaration then
+ Error_Msg_N
+ ("aspect % not allowed for renaming declaration",
+ Aspect);
+ end if;
+
+ -- Not allowed for formal type declarations
+
+ if Nkind (N) = N_Formal_Type_Declaration then
+ Error_Msg_N
+ ("aspect % not allowed for formal type declaration",
+ Aspect);
+ end if;
+ end if;
+
-- Copy expression for later processing by the procedures
-- Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
-- Aspects corresponding to attribute definition clauses
- when Aspect_Address |
- Aspect_Alignment |
- Aspect_Bit_Order |
- Aspect_Component_Size |
- Aspect_External_Tag |
- Aspect_Input |
- Aspect_Machine_Radix |
- Aspect_Object_Size |
- Aspect_Output |
- Aspect_Read |
- Aspect_Size |
- Aspect_Small |
- Aspect_Storage_Pool |
- Aspect_Storage_Size |
- Aspect_Stream_Size |
- Aspect_Value_Size |
- Aspect_Write =>
+ when Aspect_Address |
+ Aspect_Alignment |
+ Aspect_Bit_Order |
+ Aspect_Component_Size |
+ Aspect_External_Tag |
+ Aspect_Input |
+ Aspect_Machine_Radix |
+ Aspect_Object_Size |
+ Aspect_Output |
+ Aspect_Read |
+ Aspect_Size |
+ Aspect_Small |
+ Aspect_Simple_Storage_Pool |
+ Aspect_Storage_Pool |
+ Aspect_Storage_Size |
+ Aspect_Stream_Size |
+ Aspect_Value_Size |
+ Aspect_Write =>
-- Construct the attribute definition clause
pragma Assert (not Delay_Required);
+ when Aspect_Synchronization =>
+
+ -- The aspect corresponds to pragma Implemented.
+ -- Construct the pragma
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (
+ New_Occurrence_Of (E, Loc),
+ Relocate_Node (Expr)),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Implemented));
+
+ pragma Assert (not Delay_Required);
+
-- Aspects corresponding to pragmas with two arguments, where
-- the second argument is a local name referring to the entity,
-- and the first argument is the aspect definition expression.
Set_Is_Delayed_Aspect (Aspect);
Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
+ if Is_Scalar_Type (E) then
+ Set_Default_Aspect_Value (Entity (Ent), Expr);
+ else
+ Set_Default_Aspect_Component_Value (Entity (Ent), Expr);
+ end if;
+
when Aspect_Attach_Handler =>
Aitem :=
Make_Pragma (Loc,
-- missing in cases like subtype X is Y, and we would not
-- have a place to build the predicate function).
+ -- If the type is private, indicate that its completion
+ -- has a freeze node, because that is the one that will be
+ -- visible at freeze time.
+
Set_Has_Predicates (E);
if Is_Private_Type (E)
then
Set_Has_Predicates (Full_View (E));
Set_Has_Delayed_Aspects (Full_View (E));
+ Ensure_Freeze_Node (Full_View (E));
end if;
Ensure_Freeze_Node (E);
goto Continue;
end;
+
+ when Aspect_Dimension =>
+ Analyze_Aspect_Dimension (N, Id, Expr);
+ goto Continue;
+
+ when Aspect_Dimension_System =>
+ Analyze_Aspect_Dimension_System (N, Id, Expr);
+ goto Continue;
+
end case;
-- If a delay is required, we delay the freeze (not much point in
------------------------
procedure Check_One_Function (Subp : Entity_Id) is
+ Default_Element : constant Node_Id :=
+ Find_Aspect
+ (Etype (First_Formal (Subp)),
+ Aspect_Iterator_Element);
+
begin
if not Check_Primitive_Function (Subp) then
Error_Msg_NE
Subp, Ent);
end if;
+ -- An indexing function must return either the default element of
+ -- the container, or a reference type.
+
+ if Present (Default_Element) then
+ Analyze (Default_Element);
+ if Is_Entity_Name (Default_Element)
+ and then Covers (Entity (Default_Element), Etype (Subp))
+ then
+ return;
+ end if;
+ end if;
+
+ -- Otherwise the return type must be a reference type.
+
if not Has_Implicit_Dereference (Etype (Subp)) then
Error_Msg_N
("function for indexing must return a reference type", Subp);
else
declare
- I : Interp_Index;
+ I : Interp_Index;
It : Interp;
begin
Set_Analyzed (N, True);
end if;
- -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in
- -- CodePeer mode or Alfa mode, since they are not relevant in these
- -- contexts).
+ -- Ignore some selected attributes in CodePeer mode since they are not
+ -- relevant in this context.
- if Ignore_Rep_Clauses or CodePeer_Mode or Alfa_Mode then
+ if CodePeer_Mode then
+ case Id is
+
+ -- Ignore Component_Size in CodePeer mode, to avoid changing the
+ -- internal representation of types by implicitly packing them.
+
+ when Attribute_Component_Size =>
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return;
+
+ when others =>
+ null;
+ end case;
+ end if;
+
+ -- Process Ignore_Rep_Clauses option
+
+ if Ignore_Rep_Clauses then
case Id is
-- The following should be ignored. They do not affect legality
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
- -- We do not want too ignore 'Small in CodePeer_Mode or Alfa_Mode,
- -- since it has an impact on the exact computations performed.
-
- -- Perhaps 'Small should also not be ignored by
- -- Ignore_Rep_Clauses ???
+ -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ???
when Attribute_Small =>
if Ignore_Rep_Clauses then
-- legality, e.g. failing to provide a stream attribute for a
-- type may make a program illegal.
- when Attribute_External_Tag |
- Attribute_Input |
- Attribute_Output |
- Attribute_Read |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Write =>
+ when Attribute_External_Tag |
+ Attribute_Input |
+ Attribute_Output |
+ Attribute_Read |
+ Attribute_Simple_Storage_Pool |
+ Attribute_Storage_Pool |
+ Attribute_Storage_Size |
+ Attribute_Write =>
null;
-- Other cases are errors ("attribute& cannot be set with
U_Ent := Underlying_Type (Ent);
end if;
- -- Complete other routine error checks
+ -- Avoid cascaded error
if Etype (Nam) = Any_Type then
return;
+ -- Must be declared in current scope
+
elsif Scope (Ent) /= Current_Scope then
Error_Msg_N ("entity must be declared in this scope", Nam);
return;
+ -- Must not be a source renaming (we do have some cases where the
+ -- expander generates a renaming, and those cases are OK, in such
+ -- cases any attribute applies to the renamed object as well).
+
+ elsif Is_Object (Ent)
+ and then Present (Renamed_Object (Ent))
+ then
+ -- Case of renamed object from source, this is an error
+
+ if Comes_From_Source (Renamed_Object (Ent)) then
+ Get_Name_String (Chars (N));
+ Error_Msg_Strlen := Name_Len;
+ Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Error_Msg_N
+ ("~ clause not allowed for a renaming declaration "
+ & "(RM 13.1(6))", Nam);
+ return;
+
+ -- For the case of a compiler generated renaming, the attribute
+ -- definition clause applies to the renamed object created by the
+ -- expander. The easiest general way to handle this is to create a
+ -- copy of the attribute definition clause for this object.
+
+ else
+ Insert_Action (N,
+ Make_Attribute_Definition_Clause (Loc,
+ Name =>
+ New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc),
+ Chars => Chars (N),
+ Expression => Duplicate_Subexpr (Expression (N))));
+ end if;
+
+ -- If no underlying entity, use entity itself, applies to some
+ -- previously detected error cases ???
+
elsif No (U_Ent) then
U_Ent := Ent;
+ -- Cannot specify for a subtype (exception Object/Value_Size)
+
elsif Is_Type (U_Ent)
and then not Is_First_Subtype (U_Ent)
and then Id /= Attribute_Object_Size
then
Error_Msg_N ("constant overlays a variable?", Expr);
- elsif Present (Renamed_Object (U_Ent)) then
- Error_Msg_N
- ("address clause not allowed"
- & " for a renaming declaration (RM 13.1(6))", Nam);
- return;
-
-- Imported variables can have an address clause, but then
-- the import is pretty meaningless except to suppress
-- initializations, so we do not need such variables to
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment : declare
- Align : constant Uint := Get_Alignment_Value (Expr);
+ Align : constant Uint := Get_Alignment_Value (Expr);
+ Max_Align : constant Uint := UI_From_Int (Maximum_Alignment);
begin
FOnly := True;
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
- Set_Alignment (U_Ent, Align);
+
+ -- Tagged type case, check for attempt to set alignment to a
+ -- value greater than Max_Align, and reset if so.
+
+ if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
+ Error_Msg_N
+ ("?alignment for & set to Maximum_Aligment", Nam);
+ Set_Alignment (U_Ent, Max_Align);
+
+ -- All other cases
+
+ else
+ Set_Alignment (U_Ent, Align);
+ end if;
-- For an array type, U_Ent is the first subtype. In that case,
-- also set the alignment of the anonymous base type so that
-- Storage_Pool attribute definition clause
- when Attribute_Storage_Pool => Storage_Pool : declare
+ when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
Pool : Entity_Id;
T : Entity_Id;
return;
end if;
- Analyze_And_Resolve
- (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+ if Id = Attribute_Storage_Pool then
+ Analyze_And_Resolve
+ (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
+
+ -- In the Simple_Storage_Pool case, we allow a variable of any
+ -- simple storage pool type, so we Resolve without imposing an
+ -- expected type.
+
+ else
+ Analyze_And_Resolve (Expr);
+
+ if not Present (Get_Rep_Pragma
+ (Etype (Expr), Name_Simple_Storage_Pool_Type))
+ then
+ Error_Msg_N
+ ("expression must be of a simple storage pool type", Expr);
+ end if;
+ end if;
if not Denotes_Variable (Expr) then
Error_Msg_N ("storage pool must be a variable", Expr);
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
- end Storage_Pool;
+ end;
------------------
-- Storage_Size --
-- (this is an error that will be caught elsewhere);
Append_To (Private_Decls, PBody);
+
+ -- If the invariant appears on the full view of a type, the
+ -- analysis of the private part is complete, and we must
+ -- analyze the new body explicitly.
+
+ if In_Private_Part (Current_Scope) then
+ Analyze (PBody);
+ end if;
end if;
end if;
end Build_Invariant_Procedure;
Set_Has_Predicates (SId);
Set_Predicate_Function (Typ, SId);
+ -- The predicate function is shared between views of a type.
+
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function (Full_View (Typ), SId);
+ end if;
+
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
-- All other cases
else
- Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ -- In a generic context the aspect expressions have not been
+ -- preanalyzed, so do it now. There are no conformance checks
+ -- to perform in this case.
+
+ if No (T) then
+ Check_Aspect_At_Freeze_Point (ASN);
+ return;
+
+ -- The default values attributes may be defined in the private part,
+ -- and the analysis of the expression may take place when only the
+ -- partial view is visible. The expression must be scalar, so use
+ -- the full view to resolve.
+
+ elsif (A_Id = Aspect_Default_Value
+ or else
+ A_Id = Aspect_Default_Component_Value)
+ and then Is_Private_Type (T)
+ then
+ Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T));
+ else
+ Preanalyze_Spec_Expression (End_Decl_Expr, T);
+ end if;
+
Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr);
end if;
when Aspect_Small =>
T := Universal_Real;
+ -- For a simple storage pool, we have to retrieve the type of the
+ -- pool object associated with the aspect's corresponding attribute
+ -- definition clause.
+
+ when Aspect_Simple_Storage_Pool =>
+ T := Etype (Expression (Aspect_Rep_Item (ASN)));
+
when Aspect_Storage_Pool =>
T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
Analyze (Expression (ASN));
return;
- -- Suppress/Unsuppress/Warnings should never be delayed
+ -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed
- when Aspect_Suppress |
- Aspect_Unsuppress |
- Aspect_Warnings =>
+ when Aspect_Suppress |
+ Aspect_Unsuppress |
+ Aspect_Synchronization |
+ Aspect_Warnings =>
raise Program_Error;
-- Pre/Post/Invariant/Predicate take boolean expressions
Aspect_Static_Predicate |
Aspect_Type_Invariant =>
T := Standard_Boolean;
+
+ when Aspect_Dimension |
+ Aspect_Dimension_System =>
+ raise Program_Error;
+
end case;
-- Do the preanalyze call
-- Start of processing for Rep_Item_Too_Late
begin
- -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported
- -- types, which may be frozen if they appear in a representation clause
- -- for a local type.
+ -- First make sure entity is not frozen (RM 13.1(9))
if Is_Frozen (T)
+
+ -- Exclude imported types, which may be frozen if they appear in a
+ -- representation clause for a local type.
+
and then not From_With_Type (T)
+
+ -- Exclude generated entitiesa (not coming from source). The common
+ -- case is when we generate a renaming which prematurely freezes the
+ -- renamed internal entity, but we still want to be able to set copies
+ -- of attribute values such as Size/Alignment.
+
+ and then Comes_From_Source (T)
then
Too_Late;
S := First_Subtype (T);
Target := Ancestor_Subtype (Etype (Act_Unit));
-- If either type is generic, the instantiation happens within a generic
- -- unit, and there is nothing to check. The proper check
- -- will happen when the enclosing generic is instantiated.
+ -- unit, and there is nothing to check. The proper check will happen
+ -- when the enclosing generic is instantiated.
if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
return;
end if;
-- If unchecked conversion to access type, and access type is declared
- -- in the same unit as the unchecked conversion, then set the
- -- No_Strict_Aliasing flag (no strict aliasing is implicit in this
- -- situation).
+ -- in the same unit as the unchecked conversion, then set the flag
+ -- No_Strict_Aliasing (no strict aliasing is implicit here)
if Is_Access_Type (Target) and then
In_Same_Source_Unit (Target, N)
Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
end if;
- -- Generate N_Validate_Unchecked_Conversion node for back end in
- -- case the back end needs to perform special validation checks.
+ -- Generate N_Validate_Unchecked_Conversion node for back end in case
+ -- the back end needs to perform special validation checks.
- -- Shouldn't this be in Exp_Ch13, since the check only gets done
- -- if we have full expansion and the back end is called ???
+ -- Shouldn't this be in Exp_Ch13, since the check only gets done if we
+ -- have full expansion and the back end is called ???
Vnode :=
Make_Validate_Unchecked_Conversion (Sloc (N));
OSDN Git Service
