+2012-06-26 Vincent Pucci <pucci@adacore.com>
+
+ * exp_ch3.adb (Build_Init_Statements): Don't check the parents
+ in the Rep Item Chain of the task for aspects Interrupt_Priority,
+ Priority, CPU and Dispatching_Domain.
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration): fields _Priority,
+ _CPU and _Domain are present in the corresponding record type
+ only if the task entity has a pragma, attribute definition
+ clause or aspect specification.
+ (Make_Initialize_Protection): Don't check the parents in the Rep Item
+ Chain of the task for aspects Interrupt_Priority, Priority, CPU and
+ Dispatching_Domain.
+ * freeze.adb (Freeze_Entity): Use of Evaluate_Aspects_At_Freeze_Point
+ call replaced by Analyze_Aspects_At_Freeze_Point.
+ * sem_ch13.adb, sem_ch13.ads (Analyze_Aspects_At_Freeze_Point):
+ Renaming of Evaluate_Aspects_At_Freeze_Point.
+
+2012-06-26 Yannick Moy <moy@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Detect if 'Old is used outside a
+ postcondition, and issue an error in such a case.
+
+2012-06-26 Yannick Moy <moy@adacore.com>
+
+ * gnat_rm.texi: Minor editing.
+
+2012-06-26 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c: Minor cleanup: remove unused prototype.
+ * seh_init.c: Do not create an image wide unwind info to catch
+ SEH when SEH unwind info are emitted by the compiler.
+
2012-06-19 Steven Bosscher <steven@gcc.gnu.org>
* gcc-interface/trans.c: Include target.h.
Ritem :=
Get_Rep_Item
- (Corresponding_Concurrent_Type (Scope (Id)), Nam);
+ (Corresponding_Concurrent_Type (Scope (Id)),
+ Nam,
+ Check_Parents => False);
if Present (Ritem) then
-- in the pragma, and is used to override the task stack size otherwise
-- associated with the task type.
- -- The _Priority field is always present. It will be filled at the freeze
- -- point, when the record init proc is built, to capture the expression of
- -- a Priority pragma, attribute definition clause or aspect specification
- -- (see Build_Record_Init_Proc in Exp_Ch3).
+ -- The _Priority field is present only if the task entity has a Priority or
+ -- Interrupt_Priority rep item (pragma, aspect specification or attribute
+ -- definition clause). It will be filled at the freeze point, when the
+ -- record init proc is built, to capture the expression of the rep item
+ -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
+ -- here since aspect evaluations are delayed till the freeze point.
-- The _Task_Info field is present only if a Task_Info pragma appears in
-- the task definition. The expression captures the argument that was
-- present in the pragma, and is used to provide the Task_Image parameter
-- to the call to Create_Task.
- -- The _CPU field is always present. It will be filled at the freeze point,
- -- when the record init proc is built, to capture the expression of a CPU
- -- pragma, attribute definition clause or aspect specification (see
- -- Build_Record_Init_Proc in Exp_Ch3).
+ -- The _CPU field is present only if the task entity has a CPU rep item
+ -- (pragma, aspect specification or attribute definition clause). It will
+ -- be filled at the freeze point, when the record init proc is built, to
+ -- capture the expression of the rep item (see Build_Record_Init_Proc in
+ -- Exp_Ch3). Note that it cannot be filled here since aspect evaluations
+ -- are delayed till the freeze point.
-- The _Relative_Deadline field is present only if a Relative_Deadline
-- pragma appears in the task definition. The expression captures the
-- argument that was present in the pragma, and is used to provide the
-- Relative_Deadline parameter to the call to Create_Task.
- -- The _Domain field is always present. It will be filled at the freeze
- -- point, when the record init proc is built, to capture the expression of
- -- a Dispatching_Domain pragma, attribute definition clause or aspect
- -- specification (see Build_Record_Init_Proc in Exp_Ch3).
+ -- The _Domain field is present only if the task entity has a
+ -- Dispatching_Domain rep item (pragma, aspect specification or attribute
+ -- definition clause). It will be filled at the freeze point, when the
+ -- record init proc is built, to capture the expression of the rep item
+ -- (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot be filled
+ -- here since aspect evaluations are delayed till the freeze point.
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
- -- Add the _Priority component with no expression
+ -- Add the _Priority component if a Interrupt_Priority or Priority rep
+ -- item is present.
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uPriority),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (Standard_Integer, Loc))));
+ if Has_Rep_Item (TaskId, Name_Priority, Check_Parents => False) then
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uPriority),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Standard_Integer, Loc))));
+ end if;
-- Add the _Size component if a Storage_Size pragma is present
(TaskId, Name_Task_Info, Check_Parents => False)))))));
end if;
- -- Add the _CPU component with no expression
+ -- Add the _CPU component if a CPU rep item is present
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uCPU),
+ if Has_Rep_Item (TaskId, Name_CPU, Check_Parents => False) then
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uCPU),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_CPU_Range), Loc))));
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_CPU_Range), Loc))));
+ end if;
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
Get_Relative_Deadline_Pragma (Taskdef))))))));
end if;
- -- Add the _Dispatching_Domain component with no expression. If we are
- -- using a restricted run time this component will not be added
- -- (dispatching domains are not allowed by the Ravenscar profile).
+ -- Add the _Dispatching_Domain component if a Dispatching_Domain rep
+ -- item is present. If we are using a restricted run time this component
+ -- will not be added (dispatching domains are not allowed by the
+ -- Ravenscar profile).
- if not Restricted_Profile then
+ if not Restricted_Profile
+ and then
+ Has_Rep_Item
+ (TaskId, Name_Dispatching_Domain, Check_Parents => False)
+ then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
-- Interrupt_Priority'Last, an implementation-defined value, see
-- (RM D.3(10)).
- if Has_Rep_Item (Ptyp, Name_Priority) then
+ if Has_Rep_Item (Ptyp, Name_Priority, Check_Parents => False) then
declare
Prio_Clause : constant Node_Id :=
- Get_Rep_Item (Ptyp, Name_Priority);
+ Get_Rep_Item
+ (Ptyp, Name_Priority, Check_Parents => False);
Prio : Node_Id;
Temp : Entity_Id;
-- Priority parameter. Set to Unspecified_Priority unless there is a
-- Priority rep item, in which case we take the value from the rep item.
- if Has_Rep_Item (Ttyp, Name_Priority) then
+ if Has_Rep_Item (Ttyp, Name_Priority, Check_Parents => False) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
-- passed as an Integer because in the case of unspecified CPU the
-- value is not in the range of CPU_Range.
- if Has_Rep_Item (Ttyp, Name_CPU) then
+ if Has_Rep_Item (Ttyp, Name_CPU, Check_Parents => False) then
Append_To (Args,
Convert_To (Standard_Integer,
Make_Selected_Component (Loc,
-- Case where Dispatching_Domain rep item applies: use given value
- if Has_Rep_Item (Ttyp, Name_Dispatching_Domain) then
+ if Has_Rep_Item
+ (Ttyp, Name_Dispatching_Domain, Check_Parents => False)
+ then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
end if;
-- Deal with delayed aspect specifications. The analysis of the
- -- aspect is required to be delayed to the freeze point, so we
- -- evaluate the pragma or attribute definition clause in the tree at
+ -- aspect is required to be delayed to the freeze point, thus we
+ -- analyze the pragma or attribute definition clause in the tree at
-- this point. We also analyze the aspect specification node at the
-- freeze point when the aspect doesn't correspond to
-- pragma/attribute definition clause.
if Has_Delayed_Aspects (E) then
- Evaluate_Aspects_At_Freeze_Point (E);
+ Analyze_Aspects_At_Freeze_Point (E);
end if;
-- Here to freeze the entity
* Mechanism_Code::
* Null_Parameter::
* Object_Size::
-* Old::
* Passed_By_Reference::
* Pool_Address::
* Range_Length::
* Mechanism_Code::
* Null_Parameter::
* Object_Size::
-* Old::
* Passed_By_Reference::
* Pool_Address::
* Range_Length::
integer field, and so the default size of record objects for this type
will be 64 (8 bytes).
-@node Old
-@unnumberedsec Old
-@cindex Capturing Old values
-@cindex Postconditions
-@noindent
-The attribute Prefix'Old can be used within a
-subprogram body or within a precondition or
-postcondition pragma. The effect is to
-refer to the value of the prefix on entry. So for
-example if you have an argument of a record type X called Arg1,
-you can refer to Arg1.Field'Old which yields the value of
-Arg1.Field on entry. The implementation simply involves generating
-an object declaration which captures the value on entry.
-The prefix must denote an object of a nonlimited type (since limited types
-cannot be copied to capture their values) and it must not reference a local
-variable (since local variables do not exist at subprogram entry time). Note
-that the variable introduced by a quantified expression is a local variable.
-The following example shows the use of 'Old to implement
-a test of a postcondition:
-
-@smallexample @c ada
-with Old_Pkg;
-procedure Old is
-begin
- Old_Pkg.Incr;
-end Old;
-
-package Old_Pkg is
- procedure Incr;
-end Old_Pkg;
-
-package body Old_Pkg is
- Count : Natural := 0;
-
- procedure Incr is
- begin
- ... code manipulating the value of Count
-
- pragma Assert (Count = Count'Old + 1);
- end Incr;
-end Old_Pkg;
-@end smallexample
-
-@noindent
-Note that it is allowed to apply 'Old to a constant entity, but this will
-result in a warning, since the old and new values will always be the same.
-
@node Passed_By_Reference
@unnumberedsec Passed_By_Reference
@cindex Parameters, when passed by reference
|
+--> __gnat_personality_v0 (context, exception)
|
- +--> get_region_descriptor_for (context)
+ +--> get_region_description_for (context)
|
- +--> get_action_descriptor_for (context, exception, region)
+ +--> get_action_description_for (context, exception, region)
| |
| +--> get_call_site_action_for (context, region)
| (one version for each underlying scheme)
automatic backtraces upon exception raise, as provided through the
GNAT.Traceback facilities. */
extern void __gnat_notify_handled_exception (void);
-extern void __gnat_notify_unhandled_exception (void);
/* Below is the eh personality routine per se. We currently assume that only
GNU-Ada exceptions are met. */
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-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- *
the loaded DLL (for example it results in unexpected behaviors in the
Win32 subsystem. */
+#ifndef __SEH__
+ /* Don't use this trick when SEH are emitted by gcc, as it will conflict with
+ them. */
asm
(
" .section .rdata, \"dr\"\n"
"\n"
" .text\n"
);
+#endif /* __SEH__ */
void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED)
{
-- Old --
---------
- when Attribute_Old =>
+ when Attribute_Old => Old : declare
+ CS : Entity_Id;
+ -- The enclosing scope, excluding loops for quantified expressions.
+ -- During analysis, it is the postcondition subprogram. During
+ -- pre-analysis, it is the scope of the subprogram declaration.
+
+ Prag : Node_Id;
+ -- During pre-analysis, Prag is the enclosing pragma node if any
+
+ begin
+ -- Find enclosing scopes, excluding loops
+
+ CS := Current_Scope;
+ while Ekind (CS) = E_Loop loop
+ CS := Scope (CS);
+ end loop;
- -- The attribute reference is a primary. If expressions follow, the
- -- attribute reference is an indexable object, so rewrite the node
+ -- If we are in Spec_Expression mode, this should be the prescan of
+ -- the postcondition (or contract case, or test case) pragma.
+
+ if In_Spec_Expression then
+
+ -- Check in postcondition or Ensures clause
+
+ Prag := N;
+ while not Nkind_In (Prag, N_Pragma,
+ N_Function_Specification,
+ N_Procedure_Specification,
+ N_Subprogram_Body)
+ loop
+ Prag := Parent (Prag);
+ end loop;
+
+ if Nkind (Prag) /= N_Pragma then
+ Error_Attr ("% attribute can only appear in postcondition", P);
+
+ elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case
+ or else
+ Get_Pragma_Id (Prag) = Pragma_Test_Case
+ then
+ declare
+ Arg_Ens : constant Node_Id :=
+ Get_Ensures_From_CTC_Pragma (Prag);
+ Arg : Node_Id;
+
+ begin
+ Arg := N;
+ while Arg /= Prag and Arg /= Arg_Ens loop
+ Arg := Parent (Arg);
+ end loop;
+
+ if Arg /= Arg_Ens then
+ if Get_Pragma_Id (Prag) = Pragma_Contract_Case then
+ Error_Attr
+ ("% attribute misplaced inside contract case", P);
+ else
+ Error_Attr
+ ("% attribute misplaced inside test case", P);
+ end if;
+ end if;
+ end;
+
+ elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then
+ Error_Attr ("% attribute can only appear in postcondition", P);
+ end if;
+
+ -- Body case, where we must be inside a generated _Postcondition
+ -- procedure, or else the attribute use is definitely misplaced. The
+ -- postcondition itself may have generated transient scopes, and is
+ -- not necessarily the current one.
+
+ else
+ while Present (CS) and then CS /= Standard_Standard loop
+ if Chars (CS) = Name_uPostconditions then
+ exit;
+ else
+ CS := Scope (CS);
+ end if;
+ end loop;
+
+ if Chars (CS) /= Name_uPostconditions then
+ Error_Attr ("% attribute can only appear in postcondition", P);
+ end if;
+ end if;
+
+ -- Either the attribute reference is generated for a Requires
+ -- clause, in which case no expressions follow, or it is a
+ -- primary. In that case, if expressions follow, the attribute
+ -- reference is an indexable object, so rewrite the node
-- accordingly.
if Present (E1) then
Check_E0;
- -- Prefix has not been analyzed yet, and its full analysis will take
- -- place during expansion (see below).
+ -- Prefix has not been analyzed yet, and its full analysis will
+ -- take place during expansion (see below).
Preanalyze_And_Resolve (P);
P_Type := Etype (P);
Set_Etype (N, P_Type);
- if No (Current_Subprogram) then
- Error_Attr ("attribute % can only appear within subprogram", N);
- end if;
-
if Is_Limited_Type (P_Type) then
Error_Attr ("attribute % cannot apply to limited objects", P);
end if;
("?attribute Old applied to constant has no effect", P);
end if;
- -- Check that the expression does not refer to local entities
-
- Check_Local : declare
- Subp : Entity_Id := Current_Subprogram;
-
- function Process (N : Node_Id) return Traverse_Result;
- -- Check that N does not contain references to local variables or
- -- other local entities of Subp.
-
- -------------
- -- Process --
- -------------
-
- function Process (N : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then not Is_Formal (Entity (N))
- and then Enclosing_Subprogram (Entity (N)) = Subp
- then
- Error_Msg_Node_1 := Entity (N);
- Error_Attr
- ("attribute % cannot refer to local variable&", N);
- end if;
-
- return OK;
- end Process;
-
- procedure Check_No_Local is new Traverse_Proc;
-
- -- Start of processing for Check_Local
-
- begin
- Check_No_Local (P);
-
- if In_Parameter_Specification (P) then
-
- -- We have additional restrictions on using 'Old in parameter
- -- specifications.
-
- if Present (Enclosing_Subprogram (Current_Subprogram)) then
-
- -- Check that there is no reference to the enclosing
- -- subprogram local variables. Otherwise, we might end up
- -- being called from the enclosing subprogram and thus using
- -- 'Old on a local variable which is not defined at entry
- -- time.
-
- Subp := Enclosing_Subprogram (Current_Subprogram);
- Check_No_Local (P);
-
- else
- -- We must prevent default expression of library-level
- -- subprogram from using 'Old, as the subprogram may be
- -- used in elaboration code for which there is no enclosing
- -- subprogram.
-
- Error_Attr
- ("attribute % can only appear within subprogram", N);
- end if;
- end if;
- end Check_Local;
-
-- The attribute appears within a pre/postcondition, but refers to
- -- an entity in the enclosing subprogram. If it is a component of a
- -- formal its expansion might generate actual subtypes that may be
- -- referenced in an inner context, and which must be elaborated
- -- within the subprogram itself. As a result we create a declaration
- -- for it and insert it at the start of the enclosing subprogram
- -- This is properly an expansion activity but it has to be performed
- -- now to prevent out-of-order issues.
+ -- an entity in the enclosing subprogram. If it is a component of
+ -- a formal its expansion might generate actual subtypes that may
+ -- be referenced in an inner context, and which must be elaborated
+ -- within the subprogram itself. As a result we create a
+ -- declaration for it and insert it at the start of the enclosing
+ -- subprogram. This is properly an expansion activity but it has
+ -- to be performed now to prevent out-of-order issues.
if Nkind (P) = N_Selected_Component
and then Has_Discriminants (Etype (Prefix (P)))
Set_Etype (P, P_Type);
Expand (N);
end if;
+ end Old;
----------------------
-- Overlaps_Storage --
end if;
-- If we are in the scope of a function and in Spec_Expression mode,
- -- this is likely the prescan of the postcondition pragma, and we
- -- just set the proper type. If there is an error it will be caught
- -- when the real Analyze call is done.
+ -- this is likely the prescan of the postcondition (or contract case,
+ -- or test case) pragma, and we just set the proper type. If there is
+ -- an error it will be caught when the real Analyze call is done.
if Ekind (CS) = E_Function
and then In_Spec_Expression
Error_Attr;
end if;
- -- Check in postcondition of function
+ -- Check in postcondition or Ensures clause of function
Prag := N;
while not Nkind_In (Prag, N_Pragma,
end if;
-- Body case, where we must be inside a generated _Postcondition
- -- procedure, and the prefix must be on the scope stack, or else
- -- the attribute use is definitely misplaced. The condition itself
+ -- procedure, and the prefix must be on the scope stack, or else the
+ -- attribute use is definitely misplaced. The postcondition itself
-- may have generated transient scopes, and is not necessarily the
-- current one.
end if;
end Alignment_Check_For_Size_Change;
+ -------------------------------------
+ -- Analyze_Aspects_At_Freeze_Point --
+ -------------------------------------
+
+ procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
+ ASN : Node_Id;
+ A_Id : Aspect_Id;
+ Ritem : Node_Id;
+
+ procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
+ -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
+ -- the aspect specification node ASN.
+
+ procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
+ -- Given an aspect specification node ASN whose expression is an
+ -- optional Boolean, this routines creates the corresponding pragma
+ -- at the freezing point.
+
+ ----------------------------------
+ -- Analyze_Aspect_Default_Value --
+ ----------------------------------
+
+ procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
+ Ent : constant Entity_Id := Entity (ASN);
+ Expr : constant Node_Id := Expression (ASN);
+ Id : constant Node_Id := Identifier (ASN);
+
+ begin
+ Error_Msg_Name_1 := Chars (Id);
+
+ if not Is_Type (Ent) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ return;
+
+ elsif not Is_First_Subtype (Ent) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ return;
+
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (Ent)
+ then
+ Error_Msg_N ("aspect% can only be applied to scalar type", Id);
+ return;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (Ent) then
+ Error_Msg_N ("aspect% can only be applied to array type", Id);
+ return;
+
+ elsif not Is_Scalar_Type (Component_Type (Ent)) then
+ Error_Msg_N ("aspect% requires scalar components", Id);
+ return;
+ end if;
+ end if;
+
+ Set_Has_Default_Aspect (Base_Type (Ent));
+
+ if Is_Scalar_Type (Ent) then
+ Set_Default_Aspect_Value (Ent, Expr);
+ else
+ Set_Default_Aspect_Component_Value (Ent, Expr);
+ end if;
+ end Analyze_Aspect_Default_Value;
+
+ -------------------------------------
+ -- Make_Pragma_From_Boolean_Aspect --
+ -------------------------------------
+
+ procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
+ Ident : constant Node_Id := Identifier (ASN);
+ A_Name : constant Name_Id := Chars (Ident);
+ A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
+ Ent : constant Entity_Id := Entity (ASN);
+ Expr : constant Node_Id := Expression (ASN);
+ Loc : constant Source_Ptr := Sloc (ASN);
+
+ Prag : Node_Id;
+
+ procedure Check_False_Aspect_For_Derived_Type;
+ -- This procedure checks for the case of a false aspect for a derived
+ -- type, which improperly tries to cancel an aspect inherited from
+ -- the parent.
+
+ -----------------------------------------
+ -- Check_False_Aspect_For_Derived_Type --
+ -----------------------------------------
+
+ procedure Check_False_Aspect_For_Derived_Type is
+ Par : Node_Id;
+
+ begin
+ -- We are only checking derived types
+
+ if not Is_Derived_Type (E) then
+ return;
+ end if;
+
+ Par := Nearest_Ancestor (E);
+
+ case A_Id is
+ when Aspect_Atomic | Aspect_Shared =>
+ if not Is_Atomic (Par) then
+ return;
+ end if;
+
+ when Aspect_Atomic_Components =>
+ if not Has_Atomic_Components (Par) then
+ return;
+ end if;
+
+ when Aspect_Discard_Names =>
+ if not Discard_Names (Par) then
+ return;
+ end if;
+
+ when Aspect_Pack =>
+ if not Is_Packed (Par) then
+ return;
+ end if;
+
+ when Aspect_Unchecked_Union =>
+ if not Is_Unchecked_Union (Par) then
+ return;
+ end if;
+
+ when Aspect_Volatile =>
+ if not Is_Volatile (Par) then
+ return;
+ end if;
+
+ when Aspect_Volatile_Components =>
+ if not Has_Volatile_Components (Par) then
+ return;
+ end if;
+
+ when others =>
+ return;
+ end case;
+
+ -- Fall through means we are canceling an inherited aspect
+
+ Error_Msg_Name_1 := A_Name;
+ Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
+ Expr,
+ E);
+
+ end Check_False_Aspect_For_Derived_Type;
+
+ -- Start of processing for Make_Pragma_From_Boolean_Aspect
+
+ begin
+ if Is_False (Static_Boolean (Expr)) then
+ Check_False_Aspect_For_Derived_Type;
+
+ else
+ Prag :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (
+ New_Occurrence_Of (Ent, Sloc (Ident))),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Ident), Chars (Ident)));
+
+ Set_From_Aspect_Specification (Prag, True);
+ Set_Corresponding_Aspect (Prag, ASN);
+ Set_Aspect_Rep_Item (ASN, Prag);
+ Set_Is_Delayed_Aspect (Prag);
+ Set_Parent (Prag, ASN);
+ end if;
+
+ end Make_Pragma_From_Boolean_Aspect;
+
+ -- Start of processing for Analyze_Aspects_At_Freeze_Point
+
+ begin
+ -- Must be declared in current scope. This is need for a generic
+ -- context.
+
+ if Scope (E) /= Current_Scope then
+ return;
+ end if;
+
+ -- Look for aspect specification entries for this entity
+
+ ASN := First_Rep_Item (E);
+
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Aspect_Specification
+ and then Entity (ASN) = E
+ and then Is_Delayed_Aspect (ASN)
+ then
+ A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
+
+ case A_Id is
+ -- For aspects whose expression is an optional Boolean, make
+ -- the corresponding pragma at the freezing point.
+
+ when Boolean_Aspects |
+ Library_Unit_Aspects =>
+ Make_Pragma_From_Boolean_Aspect (ASN);
+
+ -- Special handling for aspects that don't correspond to
+ -- pragmas/attributes.
+
+ when Aspect_Default_Value |
+ Aspect_Default_Component_Value =>
+ Analyze_Aspect_Default_Value (ASN);
+
+ when others => null;
+ end case;
+
+ Ritem := Aspect_Rep_Item (ASN);
+
+ if Present (Ritem) then
+ Analyze (Ritem);
+ end if;
+ end if;
+
+ Next_Rep_Item (ASN);
+ end loop;
+ end Analyze_Aspects_At_Freeze_Point;
+
-----------------------------------
-- Analyze_Aspect_Specifications --
-----------------------------------
-- declaration. We do not have to worry about delay issues
-- since the pragma processing takes care of this.
- Set_Is_Delayed_Aspect (Aspect);
Delay_Required := False;
-- Case 3 : Aspects that don't correspond to pragma/attribute
end if;
end Check_Size;
- --------------------------------------
- -- Evaluate_Aspects_At_Freeze_Point --
- --------------------------------------
-
- procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id) is
- ASN : Node_Id;
- A_Id : Aspect_Id;
- Ritem : Node_Id;
-
- procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
- -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
- -- the aspect specification node ASN.
-
- procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
- -- Given an aspect specification node ASN whose expression is an
- -- optional Boolean, this routines creates the corresponding pragma
- -- at the freezing point.
-
- ----------------------------------
- -- Analyze_Aspect_Default_Value --
- ----------------------------------
-
- procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
- Ent : constant Entity_Id := Entity (ASN);
- Expr : constant Node_Id := Expression (ASN);
- Id : constant Node_Id := Identifier (ASN);
-
- begin
- Error_Msg_Name_1 := Chars (Id);
-
- if not Is_Type (Ent) then
- Error_Msg_N ("aspect% can only apply to a type", Id);
- return;
-
- elsif not Is_First_Subtype (Ent) then
- Error_Msg_N ("aspect% cannot apply to subtype", Id);
- return;
-
- elsif A_Id = Aspect_Default_Value
- and then not Is_Scalar_Type (Ent)
- then
- Error_Msg_N ("aspect% can only be applied to scalar type", Id);
- return;
-
- elsif A_Id = Aspect_Default_Component_Value then
- if not Is_Array_Type (Ent) then
- Error_Msg_N ("aspect% can only be applied to array type", Id);
- return;
-
- elsif not Is_Scalar_Type (Component_Type (Ent)) then
- Error_Msg_N ("aspect% requires scalar components", Id);
- return;
- end if;
- end if;
-
- Set_Has_Default_Aspect (Base_Type (Ent));
-
- if Is_Scalar_Type (Ent) then
- Set_Default_Aspect_Value (Ent, Expr);
- else
- Set_Default_Aspect_Component_Value (Ent, Expr);
- end if;
- end Analyze_Aspect_Default_Value;
-
- -------------------------------------
- -- Make_Pragma_From_Boolean_Aspect --
- -------------------------------------
-
- procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
- Ident : constant Node_Id := Identifier (ASN);
- A_Name : constant Name_Id := Chars (Ident);
- A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
- Ent : constant Entity_Id := Entity (ASN);
- Expr : constant Node_Id := Expression (ASN);
- Loc : constant Source_Ptr := Sloc (ASN);
-
- Prag : Node_Id;
-
- procedure Check_False_Aspect_For_Derived_Type;
- -- This procedure checks for the case of a false aspect for a derived
- -- type, which improperly tries to cancel an aspect inherited from
- -- the parent.
-
- -----------------------------------------
- -- Check_False_Aspect_For_Derived_Type --
- -----------------------------------------
-
- procedure Check_False_Aspect_For_Derived_Type is
- Par : Node_Id;
-
- begin
- -- We are only checking derived types
-
- if not Is_Derived_Type (E) then
- return;
- end if;
-
- Par := Nearest_Ancestor (E);
-
- case A_Id is
- when Aspect_Atomic | Aspect_Shared =>
- if not Is_Atomic (Par) then
- return;
- end if;
-
- when Aspect_Atomic_Components =>
- if not Has_Atomic_Components (Par) then
- return;
- end if;
-
- when Aspect_Discard_Names =>
- if not Discard_Names (Par) then
- return;
- end if;
-
- when Aspect_Pack =>
- if not Is_Packed (Par) then
- return;
- end if;
-
- when Aspect_Unchecked_Union =>
- if not Is_Unchecked_Union (Par) then
- return;
- end if;
-
- when Aspect_Volatile =>
- if not Is_Volatile (Par) then
- return;
- end if;
-
- when Aspect_Volatile_Components =>
- if not Has_Volatile_Components (Par) then
- return;
- end if;
-
- when others =>
- return;
- end case;
-
- -- Fall through means we are canceling an inherited aspect
-
- Error_Msg_Name_1 := A_Name;
- Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
- Expr,
- E);
-
- end Check_False_Aspect_For_Derived_Type;
-
- -- Start of processing for Make_Pragma_From_Boolean_Aspect
-
- begin
- if Is_False (Static_Boolean (Expr)) then
- Check_False_Aspect_For_Derived_Type;
-
- else
- Prag :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations => New_List (
- New_Occurrence_Of (Ent, Sloc (Ident))),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Ident), Chars (Ident)));
-
- Set_From_Aspect_Specification (Prag, True);
- Set_Corresponding_Aspect (Prag, ASN);
- Set_Aspect_Rep_Item (ASN, Prag);
- Set_Is_Delayed_Aspect (Prag);
- Set_Parent (Prag, ASN);
- end if;
-
- end Make_Pragma_From_Boolean_Aspect;
-
- -- Start of processing for Evaluate_Aspects_At_Freeze_Point
-
- begin
- -- Must be declared in current scope
-
- if Scope (E) /= Current_Scope then
- return;
- end if;
-
- -- Look for aspect specification entries for this entity
-
- ASN := First_Rep_Item (E);
-
- while Present (ASN) loop
- if Nkind (ASN) = N_Aspect_Specification
- and then Entity (ASN) = E
- and then Is_Delayed_Aspect (ASN)
- then
- A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
-
- case A_Id is
- -- For aspects whose expression is an optional Boolean, make
- -- the corresponding pragma at the freezing point.
-
- when Boolean_Aspects |
- Library_Unit_Aspects =>
- Make_Pragma_From_Boolean_Aspect (ASN);
-
- -- Special handling for aspects that don't correspond to
- -- pragmas/attributes.
-
- when Aspect_Default_Value |
- Aspect_Default_Component_Value =>
- Analyze_Aspect_Default_Value (ASN);
-
- when others => null;
- end case;
-
- Ritem := Aspect_Rep_Item (ASN);
-
- if Present (Ritem) then
- Analyze (Ritem);
- end if;
- end if;
-
- Next_Rep_Item (ASN);
- end loop;
- end Evaluate_Aspects_At_Freeze_Point;
-
-------------------------
-- Get_Alignment_Value --
-------------------------
-- Quite an awkward procedure, but this is an awkard requirement!
+ procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
+ -- Analyze all the delayed aspects for entity E at freezing point
+
procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id);
-- Performs the processing described above at the freeze point, ASN is the
-- N_Aspect_Specification node for the aspect.
-- Performs the processing described above at the freeze all point, and
-- issues appropriate error messages if the visibility has indeed changed.
-- Again, ASN is the N_Aspect_Specification node for the aspect.
-
- procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id);
- -- Evaluates all the delayed aspects for entity E at freezing point
end Sem_Ch13;
projects / platform / upstream / linaro-gcc.git / commitdiff