diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 65 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch8.adb | 141 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/restrict.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/restrict.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/rident.ads | 422 | ||||
| -rw-r--r-- | gcc/ada/s-os_lib.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/s-taprop-mingw.adb | 49 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 380 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/tracebak.c | 72 |
17 files changed, 943 insertions, 291 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 30bd972..627ccaf 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,68 @@ +2012-07-09 Thomas Quinot <quinot@adacore.com> + + * einfo.adb (Set_Reverse_Storage_Order): Update assertion, + flag is now valid for array types as well. + +2012-07-09 Tristan Gingold <gingold@adacore.com> + + * tracebak.c: Implement __gnat_backtrace for Win64 SEH. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * einfo.ads: Minor reformatting. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Handle as + renaming_as_body renamings of predefined dispatching equality + and unequality operators. + +2012-07-09 Robert Dewar <dewar@adacore.com> + + * rident.ads: Do not instantiate r-ident.ads, this is now an + independent unit. + +2012-07-09 Javier Miranda <miranda@adacore.com> + + * exp_disp.adb (Write_DT): Avoid runtime crash of this debugging + routine. + * sem_disp.adb (Find_Dispatching_Time): Protect this routine + against partially decorated entities. + +2012-07-09 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Check_Size): Reject a size clause that specifies + a value greater than Int'Last for a scalar type. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_ch9.adb (Allows_Lock_Free_Implementation): type must support + atomic operation moved to the protected body case. No non-elementary + out parameter moved to the protected declaration case. Functions have + only one lock-free restriction. + (Analyze_Protected_Type_Declaration): Issue a warning when + Priority given with Lock_Free. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb: Grammar of aspect Dimension fixed. + +2012-07-09 Vincent Pucci <pucci@adacore.com> + + * freeze.adb (Freeze_Record_Type): Code reorg in order to avoid + pushing and popping the scope stack whenever a delayed aspect occurs. + +2012-07-09 Gary Dismukes <dismukes@adacore.com> + + * s-os_lib.ads: Remove pragma Elaborate_Body, as + this is now unnecessary due to recently added pragma Preelaborate. + +2012-07-09 Jose Ruiz <ruiz@adacore.com> + + * s-taprop-mingw.adb (Set_Priority): Remove the code that was + previously in place to reorder the ready queue when a task drops + its priority due to the loss of inherited priority. + 2012-07-09 Robert Dewar <dewar@adacore.com> * layout.adb, i-cstrea.ads, a-ststio.ads, prj-util.ads, sem_cat.adb, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index d2af1cf..6ef644a 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5163,7 +5163,8 @@ package body Einfo is procedure Set_Reverse_Storage_Order (Id : E; V : B := True) is begin pragma Assert - (Is_Record_Type (Id) and then Is_Base_Type (Id)); + (Is_Base_Type (Id) + and then (Is_Record_Type (Id) or else Is_Array_Type (Id))); Set_Flag93 (Id, V); end Set_Reverse_Storage_Order; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e3a5c56..3da5301 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -5021,6 +5021,7 @@ package Einfo is -- Has_Component_Size_Clause (Flag68) (base type only) -- Has_Pragma_Pack (Flag121) (impl base type only) -- Is_Constrained (Flag12) + -- Reverse_Storage_Order (Flag93) (base type only) -- Next_Index (synth) -- Number_Dimensions (synth) -- (plus type attributes) diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index a0e9d4c..3647ceb 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -239,6 +239,44 @@ package body Exp_Ch8 is ---------------------------------------------- procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Id : constant Entity_Id := Defining_Entity (N); + + function Build_Body_For_Renaming return Node_Id; + -- Build and return the body for the renaming declaration of an + -- equality or unequality operator. + + function Build_Body_For_Renaming return Node_Id is + Body_Id : Entity_Id; + Decl : Node_Id; + + begin + Set_Alias (Id, Empty); + Set_Has_Completion (Id, False); + Rewrite (N, + Make_Subprogram_Declaration (Sloc (N), + Specification => Specification (N))); + Set_Has_Delayed_Freeze (Id); + + Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id)); + Set_Debug_Info_Needed (Body_Id); + + Decl := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Body_Id, + Parameter_Specifications => Copy_Parameter_List (Id), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => Empty_List, + Handled_Statement_Sequence => Empty); + + return Decl; + end Build_Body_For_Renaming; + + -- Local variable + Nam : constant Node_Id := Name (N); begin @@ -259,25 +297,26 @@ package body Exp_Ch8 is Force_Evaluation (Prefix (Nam)); end if; - -- Check whether this is a renaming of a predefined equality on an - -- untagged record type (AI05-0123). + -- Handle cases where we build a body for a renamed equality if Is_Entity_Name (Nam) - and then Chars (Entity (Nam)) = Name_Op_Eq + and then (Chars (Entity (Nam)) = Name_Op_Ne + or else Chars (Entity (Nam)) = Name_Op_Eq) and then Scope (Entity (Nam)) = Standard_Standard - and then Ada_Version >= Ada_2012 then declare - Loc : constant Source_Ptr := Sloc (N); - Id : constant Entity_Id := Defining_Entity (N); - Typ : constant Entity_Id := Etype (First_Formal (Id)); - - Decl : Node_Id; - Body_Id : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), Chars (Id)); + Left : constant Entity_Id := First_Formal (Id); + Right : constant Entity_Id := Next_Formal (Left); + Typ : constant Entity_Id := Etype (Left); + Decl : Node_Id; begin - if Is_Record_Type (Typ) + -- Check whether this is a renaming of a predefined equality on an + -- untagged record type (AI05-0123). + + if Ada_Version >= Ada_2012 + and then Chars (Entity (Nam)) = Name_Op_Eq + and then Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then @@ -288,23 +327,7 @@ package body Exp_Ch8 is -- declaration, and the body is inserted at the end of the -- current declaration list to prevent premature freezing. - Set_Alias (Id, Empty); - Set_Has_Completion (Id, False); - Rewrite (N, - Make_Subprogram_Declaration (Sloc (N), - Specification => Specification (N))); - Set_Has_Delayed_Freeze (Id); - - Decl := Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Body_Id, - Parameter_Specifications => - Copy_Parameter_List (Id), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)), - Declarations => Empty_List, - Handled_Statement_Sequence => Empty); + Decl := Build_Body_For_Renaming; Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, @@ -322,7 +345,63 @@ package body Exp_Ch8 is Bodies => Declarations (Decl)))))); Append (Decl, List_Containing (N)); - Set_Debug_Info_Needed (Body_Id); + + -- Handle renamings of predefined dispatching equality operators. + -- When we analyze a renaming of the equality operator of a tagged + -- type, the predefined dispatching primitives are not available + -- (since they are added by the expander when the tagged type is + -- frozen) and hence they are left decorated as renamings of the + -- standard non-dispatching operators. Here we generate a body + -- for such renamings which invokes the predefined dispatching + -- equality operator. + + -- Example: + + -- type T is tagged null record; + -- function Eq (X, Y : T1) return Boolean renames "="; + -- function Neq (X, Y : T1) return Boolean renames "/="; + + elsif Is_Record_Type (Typ) + and then Is_Tagged_Type (Typ) + and then Is_Dispatching_Operation (Id) + and then not Is_Dispatching_Operation (Entity (Nam)) + then + pragma Assert (not Is_Frozen (Typ)); + + Decl := Build_Body_For_Renaming; + + -- Clean decoration of intrinsic subprogram + + Set_Is_Intrinsic_Subprogram (Id, False); + Set_Convention (Id, Convention_Ada); + + if Chars (Entity (Nam)) = Name_Op_Ne then + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Left, Loc), + Right_Opnd => + New_Reference_To (Right, Loc))))))); + + else pragma Assert (Chars (Entity (Nam)) = Name_Op_Eq); + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Eq (Loc, + Left_Opnd => + New_Reference_To (Left, Loc), + Right_Opnd => + New_Reference_To (Right, Loc)))))); + end if; + + Append (Decl, List_Containing (N)); end if; end; end if; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index c0fddeb..2dc1e48 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -5777,7 +5777,7 @@ package body Exp_Disp is Prefix => New_Reference_To (TSD, Loc), Attribute_Name => Name_Address)); - -- Stage 2: Initialize the table of primitive operations + -- Stage 2: Initialize the table of user-defined primitive operations Prim_Ops_Aggr_List := New_List; @@ -8857,7 +8857,8 @@ package body Exp_Disp is -- If the DTC_Entity attribute is already set we can also output -- the name of the interface covered by this primitive (if any). - if Present (DTC_Entity (Alias (Prim))) + if Ekind_In (Alias (Prim), E_Function, E_Procedure) + and then Present (DTC_Entity (Alias (Prim))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) then Write_Str (" from interface "); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 4637e05..279e08a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1814,6 +1814,11 @@ package body Freeze is Junk : Boolean; pragma Warnings (Off, Junk); + Rec_Pushed : Boolean := False; + -- Set True if the record type scope Rec has been pushed on the scope + -- stack. Needed for the analysis of delayed aspects specified to the + -- components of Rec. + Unplaced_Component : Boolean := False; -- Set True if we find at least one component with no component -- clause (used to warn about useless Pack pragmas). @@ -1901,39 +1906,53 @@ package body Freeze is -- Start of processing for Freeze_Record_Type begin - -- Freeze components and embedded subtypes + -- Deal with delayed aspect specifications for components. The + -- analysis of the 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. Comp := First_Entity (Rec); - Prev := Empty; while Present (Comp) loop - - -- Deal with delayed aspect specifications for components. The - -- analysis of the 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 Ekind (Comp) = E_Component and then Has_Delayed_Aspects (Comp) then - Push_Scope (Rec); - - -- The visibility to the discriminants must be restored in - -- order to properly analyze the aspects. + if not Rec_Pushed then + Push_Scope (Rec); + Rec_Pushed := True; - if Has_Discriminants (Rec) then - Install_Discriminants (Rec); - Analyze_Aspects_At_Freeze_Point (Comp); - Uninstall_Discriminants (Rec); + -- The visibility to the discriminants must be restored in + -- order to properly analyze the aspects. - else - Analyze_Aspects_At_Freeze_Point (Comp); + if Has_Discriminants (Rec) then + Install_Discriminants (Rec); + end if; end if; - Pop_Scope; + Analyze_Aspects_At_Freeze_Point (Comp); + end if; + + Next_Entity (Comp); + end loop; + + -- Pop the scope if Rec scope has been pushed on the scope stack + -- during the delayed aspect analysis process. + + if Rec_Pushed then + if Has_Discriminants (Rec) then + Uninstall_Discriminants (Rec); end if; + Pop_Scope; + end if; + + -- Freeze components and embedded subtypes + + Comp := First_Entity (Rec); + Prev := Empty; + while Present (Comp) loop + -- Handle the component and discriminant case if Ekind (Comp) = E_Component diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index ee45e05..4e428c4 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -768,7 +768,7 @@ package body Restrict is ---------------------------------- -- Note: body of this function must be coordinated with list of - -- renaming declarations in System.Rident. + -- renaming declarations in Rident. function Process_Restriction_Synonyms (N : Node_Id) return Name_Id is diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index 5d03f831..d7b05d4 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -332,10 +332,10 @@ package Restrict is -- exception propagation is activated. function Process_Restriction_Synonyms (N : Node_Id) return Name_Id; - -- Id is a node whose Chars field contains the name of a restriction. - -- If it is one of synonyms that we allow for historical purposes (for - -- list see System.Rident), then the proper official name is returned. - -- Otherwise the Chars field of the argument is returned unchanged. + -- Id is a node whose Chars field contains the name of a restriction. If it + -- is one of synonyms that we allow for historical purposes (for list see + -- Rident), then the proper official name is returned. Otherwise the Chars + -- field of the argument is returned unchanged. function Restriction_Active (R : All_Restrictions) return Boolean; pragma Inline (Restriction_Active); diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads index 6f77114..2408714 100644 --- a/gcc/ada/rident.ads +++ b/gcc/ada/rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 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- -- @@ -34,16 +34,416 @@ -- it can be used by the binder without dragging in unneeded compiler -- packages. --- Note: the actual definitions of the types are in package System.Rident, --- and this package is merely an instantiation of that package. The point --- of this level of generic indirection is to allow the compile time use --- to have the image tables available (this package is not compiled with --- Discard_Names), while at run-time we do not want those image tables. +package Rident is --- Rather than have clients instantiate System.Rident directly, we have the --- single instantiation here at the library level, which means that we only --- have one copy of the image tables + -- The following enumeration type defines the set of restriction + -- identifiers that are implemented in GNAT. -with System.Rident; + -- To add a new restriction identifier, add an entry with the name to be + -- used in the pragma, and add calls to the Restrict.Check_Restriction + -- routine as appropriate. -package Rident is new System.Rident; + type Restriction_Id is + + -- The following cases are checked for consistency in the binder. The + -- binder will check that every unit either has the restriction set, or + -- does not violate the restriction. + + (Simple_Barriers, -- GNAT (Ravenscar) + No_Abort_Statements, -- (RM D.7(5), H.4(3)) + No_Access_Subprograms, -- (RM H.4(17)) + No_Allocators, -- (RM H.4(7)) + No_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) + No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) + No_Asynchronous_Control, -- (RM D.7(10)) + No_Calendar, -- GNAT + No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) + No_Delay, -- (RM H.4(21)) + No_Direct_Boolean_Operators, -- GNAT + No_Dispatch, -- (RM H.4(19)) + No_Dispatching_Calls, -- GNAT + No_Dynamic_Attachment, -- GNAT + No_Dynamic_Priorities, -- (RM D.9(9)) + No_Enumeration_Maps, -- GNAT + No_Entry_Calls_In_Elaboration_Code, -- GNAT + No_Entry_Queue, -- GNAT (Ravenscar) + No_Exception_Handlers, -- GNAT + No_Exception_Propagation, -- GNAT + No_Exception_Registration, -- GNAT + No_Exceptions, -- (RM H.4(12)) + No_Finalization, -- GNAT + No_Fixed_Point, -- (RM H.4(15)) + No_Floating_Point, -- (RM H.4(14)) + No_IO, -- (RM H.4(20)) + No_Implicit_Conditionals, -- GNAT + No_Implicit_Dynamic_Code, -- GNAT + No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Loops, -- GNAT + No_Initialize_Scalars, -- GNAT + No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) + No_Local_Protected_Objects, -- GNAT + No_Nested_Finalization, -- (RM D.7(4)) + No_Protected_Type_Allocators, -- GNAT + No_Protected_Types, -- (RM H.4(5)) + No_Recursion, -- (RM H.4(22)) + No_Reentrancy, -- (RM H.4(23)) + No_Relative_Delay, -- GNAT (Ravenscar) + No_Requeue_Statements, -- GNAT + No_Secondary_Stack, -- GNAT + No_Select_Statements, -- GNAT (Ravenscar) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) + No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT + No_Streams, -- GNAT + No_Task_Allocators, -- (RM D.7(7)) + No_Task_Attributes_Package, -- GNAT + No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) + No_Task_Termination, -- GNAT (Ravenscar) + No_Tasking, -- GNAT + No_Terminate_Alternatives, -- (RM D.7(6)) + No_Unchecked_Access, -- (RM H.4(18)) + No_Unchecked_Conversion, -- (RM H.4(16)) + No_Unchecked_Deallocation, -- (RM H.4(9)) + Static_Priorities, -- GNAT + Static_Storage_Size, -- GNAT + + -- The following require consistency checking with special rules. See + -- individual routines in unit Bcheck for details of what is required. + + No_Default_Initialization, -- GNAT + + -- The following cases do not require consistency checking and if used + -- as a configuration pragma within a specific unit, apply only to that + -- unit (e.g. if used in the package spec, do not apply to the body) + + -- Note: No_Elaboration_Code is handled specially. Like the other + -- non-partition-wide restrictions, it can only be set in a unit that + -- is part of the extended main source unit (body/spec/subunits). But + -- it is sticky, in that if it is found anywhere within any of these + -- units, it applies to all units in this extended main source. + + Immediate_Reclamation, -- (RM H.4(10)) + No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 + No_Implementation_Attributes, -- Ada 2005 AI-257 + No_Implementation_Identifiers, -- Ada 2012 AI-246 + No_Implementation_Pragmas, -- Ada 2005 AI-257 + No_Implementation_Restrictions, -- GNAT + No_Implementation_Units, -- Ada 2012 AI-242 + No_Implicit_Aliasing, -- GNAT + No_Elaboration_Code, -- GNAT + No_Obsolescent_Features, -- Ada 2005 AI-368 + No_Wide_Characters, -- GNAT + SPARK, -- GNAT + + -- The following cases require a parameter value + + -- The following entries are fully checked at compile/bind time, which + -- means that the compiler can in general tell the minimum value which + -- could be used with a restrictions pragma. The binder can deduce the + -- appropriate minimum value for the partition by taking the maximum + -- value required by any unit. + + Max_Protected_Entries, -- (RM D.7(14)) + Max_Select_Alternatives, -- (RM D.7(12)) + Max_Task_Entries, -- (RM D.7(13), H.4(3)) + + -- The following entries are also fully checked at compile/bind time, + -- and the compiler can also at least in some cases tell the minimum + -- value which could be used with a restriction pragma. The difference + -- is that the contributions are additive, so the binder deduces this + -- value by adding the unit contributions. + + Max_Tasks, -- (RM D.7(19), H.4(3)) + + -- The following entries are checked at compile time only for zero/ + -- nonzero entries. This means that the compiler can tell at compile + -- time if a restriction value of zero is (would be) violated, but that + -- the compiler cannot distinguish between different non-zero values. + + Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) + Max_Entry_Queue_Length, -- GNAT + + -- The remaining entries are not checked at compile/bind time + + Max_Storage_At_Blocking, -- (RM D.7(17)) + + Not_A_Restriction_Id); + + -- Synonyms permitted for historical purposes of compatibility. + -- Must be coordinated with Restrict.Process_Restriction_Synonym. + + Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers; + Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length; + No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment; + No_Requeue : Restriction_Id renames No_Requeue_Statements; + No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package; + + subtype All_Restrictions is Restriction_Id range + Simple_Barriers .. Max_Storage_At_Blocking; + -- All restrictions (excluding only Not_A_Restriction_Id) + + subtype All_Boolean_Restrictions is Restriction_Id range + Simple_Barriers .. SPARK; + -- All restrictions which do not take a parameter + + subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range + Simple_Barriers .. Static_Storage_Size; + -- Boolean restrictions that are checked for partition consistency. + -- Note that all parameter restrictions are checked for partition + -- consistency by default, so this distinction is only needed in the + -- case of Boolean restrictions. + + subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range + Immediate_Reclamation .. SPARK; + -- Boolean restrictions that are not checked for partition consistency + -- and that thus apply only to the current unit. Note that for these + -- restrictions, the compiler does not apply restrictions found in + -- with'ed units, parent specs etc. to the main unit, and vice versa. + + subtype All_Parameter_Restrictions is + Restriction_Id range + Max_Protected_Entries .. Max_Storage_At_Blocking; + -- All restrictions that take a parameter + + subtype Checked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Protected_Entries .. Max_Entry_Queue_Length; + -- These are the parameter restrictions that can be at least partially + -- checked at compile/binder time. Minimally, the compiler can detect + -- violations of a restriction pragma with a value of zero reliably. + + subtype Checked_Max_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Task_Entries; + -- Restrictions with parameters that can be checked in some cases by + -- maximizing among statically detected instances where the compiler + -- can determine the count. + + subtype Checked_Add_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Tasks .. Max_Tasks; + -- Restrictions with parameters that can be checked in some cases by + -- summing the statically detected instances where the compiler can + -- determine the count. + + subtype Checked_Val_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Tasks; + -- Restrictions with parameter where the count is known at least in some + -- cases by the compiler/binder. + + subtype Checked_Zero_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length; + -- Restrictions with parameters where the compiler can detect the use of + -- the feature, and hence violations of a restriction specifying a value + -- of zero, but cannot detect specific values other than zero/nonzero. + + subtype Unchecked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Storage_At_Blocking .. Max_Storage_At_Blocking; + -- Restrictions with parameters where the compiler cannot ever detect + -- corresponding compile time usage, so the binder and compiler never + -- detect violations of any restriction. + + ------------------------------------- + -- Restriction Status Declarations -- + ------------------------------------- + + -- The following declarations are used to record the current status or + -- restrictions (for the current unit, or related units, at compile time, + -- and for all units in a partition at bind time or run time). + + type Restriction_Flags is array (All_Restrictions) of Boolean; + type Restriction_Values is array (All_Parameter_Restrictions) of Natural; + type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean; + + type Restrictions_Info is record + Set : Restriction_Flags; + -- An entry is True in the Set array if a restrictions pragma has been + -- encountered for the given restriction. If the value is True for a + -- parameter restriction, then the corresponding entry in the Value + -- array gives the minimum value encountered for any such restriction. + + Value : Restriction_Values; + -- If the entry for a parameter restriction in Set is True (i.e. a + -- restrictions pragma for the restriction has been encountered), then + -- the corresponding entry in the Value array is the minimum value + -- specified by any such restrictions pragma. Note that a restrictions + -- pragma specifying a value greater than Int'Last is simply ignored. + + Violated : Restriction_Flags; + -- An entry is True in the violations array if the compiler has detected + -- a violation of the restriction. For a parameter restriction, the + -- Count and Unknown arrays have additional information. + + Count : Restriction_Values; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Count array may record additional + -- information. If the actual minimum count is known (by taking + -- maximums, or sums, depending on the restriction), it will be + -- recorded in this array. If not, then the value will remain zero. + -- The value is also zero for a non-violated restriction. + + Unknown : Parameter_Flags; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Unknown array may record additional + -- information. If the actual count is not known by the compiler (but + -- is known to be non-zero), then the entry in Unknown will be True. + -- This indicates that the value in Count is not known to be exact, + -- and the actual violation count may be higher. + + -- Note: If Violated (K) is True, then either Count (K) > 0 or + -- Unknown (K) = True. It is possible for both these to be set. + -- For example, if Count (K) = 3 and Unknown (K) is True, it means + -- that the actual violation count is at least 3 but might be higher. + end record; + + No_Restrictions : constant Restrictions_Info := + (Set => (others => False), + Value => (others => 0), + Violated => (others => False), + Count => (others => 0), + Unknown => (others => False)); + -- Used to initialize Restrictions_Info variables + + ---------------------------------- + -- Profile Definitions and Data -- + ---------------------------------- + + -- Note: to add a profile, modify the following declarations appropriately, + -- add Name_xxx to Snames, and add a branch to the conditions for pragmas + -- Profile and Profile_Warnings in the body of Sem_Prag. + + type Profile_Name is + (No_Profile, + No_Implementation_Extensions, + Ravenscar, + Restricted); + -- Names of recognized profiles. No_Profile is used to indicate that a + -- restriction came from pragma Restrictions[_Warning], as opposed to + -- pragma Profile[_Warning]. + + subtype Profile_Name_Actual is Profile_Name + range No_Implementation_Extensions .. Restricted; + -- Actual used profile names + + type Profile_Data is record + Set : Restriction_Flags; + -- Set to True if given restriction must be set for the profile, and + -- False if it need not be set (False does not mean that it must not be + -- set, just that it need not be set). If the flag is True for a + -- parameter restriction, then the Value array gives the maximum value + -- permitted by the profile. + + Value : Restriction_Values; + -- An entry in this array is meaningful only if the corresponding flag + -- in Set is True. In that case, the value in this array is the maximum + -- value of the parameter permitted by the profile. + end record; + + Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := + + (No_Implementation_Extensions => + -- Restrictions for Restricted profile + + (Set => + (No_Implementation_Aspect_Specifications => True, + No_Implementation_Attributes => True, + No_Implementation_Identifiers => True, + No_Implementation_Pragmas => True, + No_Implementation_Units => True, + others => False), + + -- Value settings for Restricted profile (none + + Value => + (others => 0)), + + -- Restricted Profile + + Restricted => + + -- Restrictions for Restricted profile + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + others => False), + + -- Value settings for Restricted profile + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + -- Ravenscar Profile + + -- Note: the table entries here only represent the + -- required restriction profile for Ravenscar. The + -- full Ravenscar profile also requires: + + -- pragma Dispatching_Policy (FIFO_Within_Priorities); + -- pragma Locking_Policy (Ceiling_Locking); + -- pragma Detect_Blocking + + Ravenscar => + + -- Restrictions for Ravenscar = Restricted profile .. + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + + -- plus these additional restrictions: + + No_Calendar => True, + No_Implicit_Heap_Allocations => True, + No_Relative_Delay => True, + No_Select_Statements => True, + No_Task_Termination => True, + Simple_Barriers => True, + others => False), + + -- Value settings for Ravenscar (same as Restricted) + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0))); + +end Rident; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index dbe3315..9848cb8 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -54,7 +54,6 @@ with System; with System.Strings; package System.OS_Lib is - pragma Elaborate_Body (OS_Lib); pragma Preelaborate; ----------------------- diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index 2aa5fd7..8b38ad8 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -716,57 +716,28 @@ package body System.Task_Primitives.Operations is -- Set_Priority -- ------------------ - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. - -- - -- Note: we assume that we are on a single processor with run-til-blocked - -- scheduling. - procedure Set_Priority (T : Task_Id; Prio : System.Any_Priority; Loss_Of_Inheritance : Boolean := False) is - Res : BOOL; - Array_Item : Integer; + Res : BOOL; + pragma Unreferenced (Loss_Of_Inheritance); begin Res := SetThreadPriority (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); pragma Assert (Res = Win32.TRUE); - if Dispatching_Policy = 'F' or else Get_Policy (Prio) = 'F' then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Let some processes a chance to arrive - - Yield; + -- Note: Annex D (RM D.2.3(5/2)) requires the task to be placed at the + -- head of its priority queue when decreasing its priority as a result + -- of a loss of inherited priority. This is not the case, but we + -- consider it an acceptable variation (RM 1.1.3(6)), given this is the + -- built-in behavior offered by the Windows operating system. - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; + -- In older versions we attempted to better approximate the Annex D + -- required behavior, but this simulation was not entirely accurate, + -- and it seems better to live with the standard Windows semantics. T.Common.Current_Priority := Prio; end Set_Priority; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 3b5b203..e475000 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7735,6 +7735,18 @@ package body Sem_Ch13 is begin Biased := False; + -- Reject patently improper size values. + + if Is_Scalar_Type (T) + and then Siz > UI_From_Int (Int'Last) + then + Error_Msg_N ("Size value too large for scalar type", N); + if Nkind (Original_Node (N)) = N_Op_Expon then + Error_Msg_N + ("\maybe '* was meant, rather than '*'*", Original_Node (N)); + end if; + end if; + -- Dismiss cases for generic types or types with previous errors if No (UT) diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 02a1905..d85f279 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -139,87 +139,69 @@ package body Sem_Ch9 is Priv_Decls : constant List_Id := Private_Declarations (Pdef); Vis_Decls : constant List_Id := Visible_Declarations (Pdef); - Comp_Id : Entity_Id; - Comp_Size : Int; - Comp_Type : Entity_Id; - Decl : Node_Id; + Decl : Node_Id; begin - -- Examine the visible declarations. Entries and entry families - -- are not allowed by the lock-free restrictions. + -- Examine the visible and the private declarations Decl := First (Vis_Decls); while Present (Decl) loop + + -- Entries and entry families are not allowed by the lock-free + -- restrictions. + if Nkind (Decl) = N_Entry_Declaration then if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", + Error_Msg_N ("entry not allowed when Lock_Free given", Decl); end if; return False; - end if; - - Next (Decl); - end loop; - - -- Examine the private declarations - - Decl := First (Priv_Decls); - while Present (Decl) loop - - -- The protected type must define at least one scalar component - - if Nkind (Decl) = N_Component_Declaration then - Comp_Id := Defining_Identifier (Decl); - Comp_Type := Etype (Comp_Id); - -- Make sure the protected component type has size and - -- alignment fields set at this point whenever this is - -- possible. + -- Non-elementary out parameters in protected procedure are not + -- allowed by the lock-free restrictions. - Layout_Type (Comp_Type); - - if Known_Esize (Comp_Type) then - Comp_Size := UI_To_Int (Esize (Comp_Type)); - - -- If the Esize (Object_Size) is unknown at compile-time, - -- look at the RM_Size (Value_Size) since it may have been - -- set by an explicit representation clause. - - else - Comp_Size := UI_To_Int (RM_Size (Comp_Type)); - end if; - - -- Check that the size of the component is 8, 16, 32 or 64 - -- bits. + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Nkind (Specification (Decl)) = + N_Procedure_Specification + and then Present + (Parameter_Specifications (Specification (Decl))) + then + declare + Par_Specs : constant List_Id := + Parameter_Specifications + (Specification (Decl)); + Par : constant Node_Id := First (Par_Specs); + Par_Typ : constant Entity_Id := + Etype (Parameter_Type (Par)); - case Comp_Size is - when 8 | 16 | 32 | 64 => - null; - when others => + begin + if Out_Present (Par) + and then not Is_Elementary_Type (Par_Typ) + then if Complain then - Error_Msg_N ("must support atomic operations for " & - "lock-free implementation", - Decl); + Error_Msg_NE + ("non-elementary out parameter& not allowed " & + "when Lock_Free given", + Par, + Defining_Identifier (Par)); end if; return False; - end case; - - -- Entries and entry families are not allowed + end if; + end; + end if; - elsif Nkind (Decl) = N_Entry_Declaration then - if Complain then - Error_Msg_N ("entry not allowed for lock-free " & - "implementation", - Decl); - end if; + -- Examine the private declarations after the visible + -- declarations. - return False; + if No (Next (Decl)) + and then List_Containing (Decl) = Vis_Decls + then + Decl := First (Priv_Decls); + else + Next (Decl); end if; - - Next (Decl); end loop; end; @@ -248,6 +230,11 @@ package body Sem_Ch9 is function Satisfies_Lock_Free_Requirements (Sub_Body : Node_Id) return Boolean is + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (Sub_Body)) = + E_Procedure; + -- Indicates if Sub_Body is a procedure body + Comp : Entity_Id := Empty; -- Track the current component which the body references @@ -260,152 +247,160 @@ package body Sem_Ch9 is function Check_Node (N : Node_Id) return Traverse_Result is begin - -- Function calls and attribute references must be static + if Is_Procedure then + -- Function calls and attribute references must be static - if Nkind (N) = N_Attribute_Reference - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N - ("non-static attribute reference not allowed", - N); - end if; + if Nkind (N) = N_Attribute_Reference + and then not Is_Static_Expression (N) + then + if Complain then + Error_Msg_N + ("non-static attribute reference not allowed", N); + end if; - return Abandon; + return Abandon; - elsif Nkind (N) = N_Function_Call - and then not Is_Static_Expression (N) - then - if Complain then - Error_Msg_N ("non-static function call not allowed", - N); - end if; + elsif Nkind (N) = N_Function_Call + and then not Is_Static_Expression (N) + then + if Complain then + Error_Msg_N ("non-static function call not allowed", + N); + end if; - return Abandon; + return Abandon; - -- Loop statements and procedure calls are prohibited + -- Loop statements and procedure calls are prohibited - elsif Nkind (N) = N_Loop_Statement then - if Complain then - Error_Msg_N ("loop not allowed", N); - end if; + elsif Nkind (N) = N_Loop_Statement then + if Complain then + Error_Msg_N ("loop not allowed", N); + end if; - return Abandon; + return Abandon; - elsif Nkind (N) = N_Procedure_Call_Statement then - if Complain then - Error_Msg_N ("procedure call not allowed", N); - end if; + elsif Nkind (N) = N_Procedure_Call_Statement then + if Complain then + Error_Msg_N ("procedure call not allowed", N); + end if; + + return Abandon; + + -- References + + elsif Nkind (N) = N_Identifier + and then Present (Entity (N)) + then + declare + Id : constant Entity_Id := Entity (N); + Sub_Id : constant Entity_Id := + Corresponding_Spec (Sub_Body); + + begin + -- Prohibit references to non-constant entities + -- outside the protected subprogram scope. + + if Ekind (Id) in Assignable_Kind + and then not Scope_Within_Or_Same (Scope (Id), + Sub_Id) + and then not Scope_Within_Or_Same (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + if Complain then + Error_Msg_NE + ("reference to global variable& not " & + "allowed", N, Id); + end if; - return Abandon; + return Abandon; + end if; + end; + end if; + end if; - -- References + -- A protected subprogram (function or procedure) may + -- reference only one component of the protected type, plus + -- the type of the component must support atomic operation. - elsif Nkind (N) = N_Identifier + if Nkind (N) = N_Identifier and then Present (Entity (N)) then declare - Id : constant Entity_Id := Entity (N); - Sub_Id : constant Entity_Id := - Corresponding_Spec (Sub_Body); + Id : constant Entity_Id := Entity (N); + Comp_Decl : Node_Id; + Comp_Id : Entity_Id := Empty; + Comp_Size : Int; + Comp_Type : Entity_Id; begin - -- Prohibit references to non-constant entities - -- outside the protected subprogram scope. - - if Ekind (Id) in Assignable_Kind - and then not Scope_Within_Or_Same (Scope (Id), - Sub_Id) - and then not Scope_Within_Or_Same (Scope (Id), - Protected_Body_Subprogram (Sub_Id)) + if Ekind (Id) = E_Component then + Comp_Id := Id; + + elsif Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id)) then - if Complain then - Error_Msg_NE - ("reference to global variable& not allowed", - N, Id); - end if; + Comp_Id := Prival_Link (Id); + end if; - return Abandon; + if Present (Comp_Id) then + Comp_Decl := Parent (Comp_Id); + Comp_Type := Etype (Comp_Id); - -- Prohibit non-scalar out parameters (scalar - -- parameters are passed by copy). + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Priv_Decls + then + -- Make sure the protected component type has + -- size and alignment fields set at this point + -- whenever this is possible. - elsif Ekind_In (Id, E_Out_Parameter, - E_In_Out_Parameter) - and then not Is_Elementary_Type (Etype (Id)) - and then Scope_Within_Or_Same (Scope (Id), Sub_Id) - then - if Complain then - Error_Msg_NE - ("non-elementary out parameter& not allowed", - N, Id); - end if; + Layout_Type (Comp_Type); - return Abandon; + if Known_Esize (Comp_Type) then + Comp_Size := UI_To_Int (Esize (Comp_Type)); - -- A protected subprogram may reference only one - -- component of the protected type. + -- If the Esize (Object_Size) is unknown at + -- compile-time, look at the RM_Size + -- (Value_Size) since it may have been set by an + -- explicit representation clause. - elsif Ekind (Id) = E_Component then - declare - Comp_Decl : constant Node_Id := Parent (Id); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Id; + else + Comp_Size := UI_To_Int (RM_Size (Comp_Type)); + end if; - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. + -- Check that the size of the component is 8, + -- 16, 32 or 64 bits. - elsif Comp /= Id then + case Comp_Size is + when 8 | 16 | 32 | 64 => + null; + when others => if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); + Error_Msg_NE + ("type of& must support atomic " & + "operations", + N, Comp_Id); end if; return Abandon; - end if; - end if; - end; + end case; - elsif Ekind_In (Id, E_Constant, E_Variable) - and then Present (Prival_Link (Id)) - then - declare - Comp_Decl : constant Node_Id := - Parent (Prival_Link (Id)); - begin - if Nkind (Comp_Decl) = N_Component_Declaration - and then Is_List_Member (Comp_Decl) - and then List_Containing (Comp_Decl) = - Priv_Decls - then - if No (Comp) then - Comp := Prival_Link (Id); - - -- Check if another protected component has - -- already been accessed by the subprogram - -- body. - - elsif Comp /= Prival_Link (Id) then - if Complain then - Error_Msg_N - ("only one protected component " & - "allowed", - N); - end if; + -- Check if another protected component has + -- already been accessed by the subprogram body. - return Abandon; + if No (Comp) then + Comp := Id; + + elsif Comp /= Id then + if Complain then + Error_Msg_N + ("only one protected component allowed", + N); end if; + + return Abandon; end if; - end; + end if; end if; end; end if; @@ -444,7 +439,7 @@ package body Sem_Ch9 is and then not Satisfies_Lock_Free_Requirements (Decl) then if Complain then - Error_Msg_N ("body prevents lock-free implementation", + Error_Msg_N ("body not allowed when Lock_Free given", Decl); end if; @@ -1787,6 +1782,43 @@ package body Sem_Ch9 is -- issued by Allows_Lock_Free_Implementation. if Uses_Lock_Free (Defining_Identifier (N)) then + -- Complain when there is an explicit aspect/pragma Priority (or + -- Interrupt_Priority) while the lock-free implementation is forced + -- by an aspect/pragma. + + declare + Id : constant Entity_Id := + Defining_Identifier (Original_Node (N)); + -- The warning must be issued on the original identifier in order + -- to deal properly with the case of a single protected object. + + Prio_Item : constant Node_Id := + Get_Rep_Item + (Defining_Identifier (N), + Name_Priority, + Check_Parents => False); + + begin + if Present (Prio_Item) then + -- Aspect case + + if Nkind (Prio_Item) = N_Aspect_Specification + or else From_Aspect_Specification (Prio_Item) + then + Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); + Error_Msg_NE ("?aspect% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + + -- Pragma case + + else + Error_Msg_Name_1 := Pragma_Name (Prio_Item); + Error_Msg_NE ("?pragma% for & has no effect when Lock_Free" & + " given", Prio_Item, Id); + end if; + end if; + end; + if not Allows_Lock_Free_Implementation (N, Complain => True) then return; end if; diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 28e8cee..917384a 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -432,7 +432,7 @@ package body Sem_Dim is ------------------------------ -- with Dimension => ( - -- [Symbol =>] SYMBOL, + -- [[Symbol =>] SYMBOL,] -- DIMENSION_VALUE -- [, DIMENSION_VALUE] -- [, DIMENSION_VALUE] diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index c4dd8ed..486d5ca 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -1696,7 +1696,9 @@ package body Sem_Disp is Ctrl_Type : Entity_Id; begin - if Present (DTC_Entity (Subp)) then + if Ekind_In (Subp, E_Function, E_Procedure) + and then Present (DTC_Entity (Subp)) + then return Scope (DTC_Entity (Subp)); -- For subprograms internally generated by derivations of tagged types diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ecec30f..e5ed869 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6254,7 +6254,7 @@ package body Sem_Prag is -- Set Detect_Blocking mode - -- Set required restrictions (see System.Rident for detailed list) + -- Set required restrictions (see Rident for detailed list) -- Set the No_Dependence rules -- No_Dependence => Ada.Asynchronous_Task_Control diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index ff2a3b6..b65dbc7 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2000-2011, Free Software Foundation, Inc. * + * Copyright (C) 2000-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- * @@ -106,6 +106,76 @@ extern void (*Unlock_Task) (void); #include "tb-ivms.c" +#elif defined (_WIN64) && defined (__SEH__) + +#include <windows.h> + +int +__gnat_backtrace (void **array, + int size, + void *exclude_min, + void *exclude_max, + int skip_frames) +{ + CONTEXT context; + UNWIND_HISTORY_TABLE history; + int i; + + /* Get the context. */ + RtlCaptureContext (&context); + + /* Setup unwind history table (a cached to speed-up unwinding). */ + memset (&history, 0, sizeof (history)); + + i = 0; + while (1) + { + PRUNTIME_FUNCTION RuntimeFunction; + KNONVOLATILE_CONTEXT_POINTERS NvContext; + ULONG64 ImageBase; + VOID *HandlerData; + ULONG64 EstablisherFrame; + + /* Get function metadata. */ + RuntimeFunction = RtlLookupFunctionEntry + (context.Rip, &ImageBase, &history); + + if (!RuntimeFunction) + { + /* In case of failure, assume this is a leaf function. */ + context.Rip = *(ULONG64 **) context.Rsp; + context.Rsp += 8; + } + else + { + /* Unwind. */ + memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS)); + RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction, + &context, &HandlerData, &EstablisherFrame, + &NvContext); + } + + /* 0 means bottom of the stack. */ + if (context.Rip == 0) + break; + + /* Skip frames. */ + if (skip_frames) + { + skip_frames--; + continue; + } + /* Excluded frames. */ + if ((void *)context.Rip >= exclude_min + && (void *)context.Rip <= exclude_max) + continue; + + array[i++] = context.Rip - 2; + if (i >= size) + break; + } + return i; +} #else /* No target specific implementation. */ |