-- --
-- 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);
end case;
end if;
- -- Process Ignore_Rep_Clauses option (we also ignore rep clauses in
- -- Alfa mode, since they are not relevant in this context).
+ -- Process Ignore_Rep_Clauses option
- if Ignore_Rep_Clauses 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
-- 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
OSDN Git Service
