-- --
-- 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;
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 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 or CodePeer_Mode or Alfa_Mode then
+ 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
elsif Align /= No_Uint then
Set_Has_Alignment_Clause (U_Ent);
+ -- 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);
+ Set_Alignment (U_Ent, Max_Align);
+
+ -- All other cases
+
else
Set_Alignment (U_Ent, Align);
end if;
-- 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,
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;
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);