diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-06-26 22:11:28 +0200 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2012-06-26 22:11:28 +0200 |
| commit | 8a0320ad5ee725a4e81229c0ba0dd25c8aa48ac5 (patch) | |
| tree | ed5a926eba95d7cf001fb68aa22d178a348f24b0 /gcc/ada | |
| parent | 59b7e90faf4f995d5b1e32b9734804b1b12917ae (diff) | |
| download | gcc-8a0320ad5ee725a4e81229c0ba0dd25c8aa48ac5.tar.gz | |
[multiple changes]
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.
From-SVN: r188995
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 32 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 101 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 49 | ||||
| -rw-r--r-- | gcc/ada/raise-gcc.c | 5 | ||||
| -rw-r--r-- | gcc/ada/seh_init.c | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 189 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 442 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.ads | 6 |
10 files changed, 433 insertions, 407 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c56d5c9b549..328e1857446 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,35 @@ +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. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index a413d88248b..7f7aa6f6bb7 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2668,7 +2668,9 @@ package body Exp_Ch3 is Ritem := Get_Rep_Item - (Corresponding_Concurrent_Type (Scope (Id)), Nam); + (Corresponding_Concurrent_Type (Scope (Id)), + Nam, + Check_Parents => False); if Present (Ritem) then diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index dd5a5d59a53..620efc96ad7 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -11270,30 +11270,36 @@ package body Exp_Ch9 is -- 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 @@ -11566,17 +11572,20 @@ package body Exp_Ch9 is 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 @@ -11623,18 +11632,20 @@ package body Exp_Ch9 is (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 @@ -11663,11 +11674,16 @@ package body Exp_Ch9 is 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 => @@ -13344,10 +13360,11 @@ package body Exp_Ch9 is -- 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; @@ -13670,7 +13687,7 @@ package body Exp_Ch9 is -- 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), @@ -13741,7 +13758,7 @@ package body Exp_Ch9 is -- 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, @@ -13790,7 +13807,9 @@ package body Exp_Ch9 is -- 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 => diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ca8c336c383..5464462a229 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2525,14 +2525,14 @@ package body Freeze is 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 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index dc09cc541e4..3b05e4779a0 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -265,7 +265,6 @@ Implementation Defined Attributes * Mechanism_Code:: * Null_Parameter:: * Object_Size:: -* Old:: * Passed_By_Reference:: * Pool_Address:: * Range_Length:: @@ -6016,7 +6015,6 @@ consideration, you should minimize the use of these attributes. * Mechanism_Code:: * Null_Parameter:: * Object_Size:: -* Old:: * Passed_By_Reference:: * Pool_Address:: * Range_Length:: @@ -6627,53 +6625,6 @@ alignment will be 4, because of the 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 diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c index 1cfb6224349..74983ae093e 100644 --- a/gcc/ada/raise-gcc.c +++ b/gcc/ada/raise-gcc.c @@ -439,9 +439,9 @@ db_phases (int phases) | +--> __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) @@ -1019,7 +1019,6 @@ setup_to_install (_Unwind_Context *uw_context, 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. */ diff --git a/gcc/ada/seh_init.c b/gcc/ada/seh_init.c index 89c9ea48e09..fa5310ffe71 100644 --- a/gcc/ada/seh_init.c +++ b/gcc/ada/seh_init.c @@ -6,7 +6,7 @@ * * * 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- * @@ -219,6 +219,9 @@ __gnat_SEH_error_handler (struct _EXCEPTION_RECORD* ExceptionRecord, 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" @@ -238,6 +241,7 @@ asm "\n" " .text\n" ); +#endif /* __SEH__ */ void __gnat_install_SEH_handler (void *eh ATTRIBUTE_UNUSED) { diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1e95a6d76ef..a5d7bee3212 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3905,10 +3905,95 @@ package body Sem_Attr is -- 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 @@ -3926,17 +4011,13 @@ package body Sem_Attr is 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; @@ -3948,77 +4029,14 @@ package body Sem_Attr is ("?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))) @@ -4028,6 +4046,7 @@ package body Sem_Attr is Set_Etype (P, P_Type); Expand (N); end if; + end Old; ---------------------- -- Overlaps_Storage -- @@ -4261,9 +4280,9 @@ package body Sem_Attr is 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 @@ -4278,7 +4297,7 @@ package body Sem_Attr is 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, @@ -4352,8 +4371,8 @@ package body Sem_Attr is 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. diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index bca378254f4..e177f930f6b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -682,6 +682,227 @@ package body Sem_Ch13 is 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 -- ----------------------------------- @@ -1199,7 +1420,6 @@ package body Sem_Ch13 is -- 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 @@ -7602,226 +7822,6 @@ package body Sem_Ch13 is 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 -- ------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index 355e11e51b6..ba335e19585 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -299,6 +299,9 @@ package Sem_Ch13 is -- 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. @@ -307,7 +310,4 @@ package Sem_Ch13 is -- 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; |