-- --
-- 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- --
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);
procedure Check_One_Function (Subp : Entity_Id) is
Default_Element : constant Node_Id :=
- Find_Aspect
- (Etype (First_Formal (Subp)),
- Aspect_Iterator_Element);
+ Find_Aspect
+ (Etype (First_Formal (Subp)),
+ Aspect_Iterator_Element);
begin
if not Check_Primitive_Function (Subp) then
if Present (Default_Element) then
Analyze (Default_Element);
if Is_Entity_Name (Default_Element)
- and then
- Covers (Entity (Default_Element), Etype (Subp))
+ and then Covers (Entity (Default_Element), Etype (Subp))
then
return;
end if;
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
-- 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.
+ -- cases any attribute applies to the renamed object as well).
elsif Is_Object (Ent)
and then Present (Renamed_Object (Ent))
- and then 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;
+ -- 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 ???
-- 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
-- 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);
OSDN Git Service
