Commit 0877856b by Arnaud Charlet

[multiple changes]

2010-10-18  Arnaud Charlet  <charlet@adacore.com>

	* g-comlin.adb (Get_Switches): Prevent dereferencing null Config.

2010-10-18  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Add entries for aspects
	Read/Write/Input/Output.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for
	handling aspects Read/Write/Input/Output.

2010-10-18  Robert Dewar  <dewar@adacore.com>

	* sem_util.adb (Note_Possible_Modification): Do not give warning for
	use of pragma Unmodified unless we are sure this is a modification.

2010-10-18  Tristan Gingold  <gingold@adacore.com>

	* sysdep.c: Add __gnat_get_stack_bounds.
	* s-taprop-mingw.adb Call __gnat_get_stack_bounds to set Pri_Stack_Info.

2010-10-18  Robert Dewar  <dewar@adacore.com>

	* a-assert.ads: Fix bad name in header.
	* sem_ch4.adb, sem_ch6.adb, sem_ch7.adb, sem_ch10.adb: Minor
	reformatting.
	* exp_aggr.adb: Fix typo in comment.

From-SVN: r165615
parent a780db15
2010-10-18 Arnaud Charlet <charlet@adacore.com>
* g-comlin.adb (Get_Switches): Prevent dereferencing null Config.
2010-10-18 Robert Dewar <dewar@adacore.com>
* aspects.ads, aspects.adb: Add entries for aspects
Read/Write/Input/Output.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for
handling aspects Read/Write/Input/Output.
2010-10-18 Robert Dewar <dewar@adacore.com>
* sem_util.adb (Note_Possible_Modification): Do not give warning for
use of pragma Unmodified unless we are sure this is a modification.
2010-10-18 Tristan Gingold <gingold@adacore.com>
* sysdep.c: Add __gnat_get_stack_bounds.
* s-taprop-mingw.adb Call __gnat_get_stack_bounds to set Pri_Stack_Info.
2010-10-18 Robert Dewar <dewar@adacore.com>
* a-assert.ads: Fix bad name in header.
* sem_ch4.adb, sem_ch6.adb, sem_ch7.adb, sem_ch10.adb: Minor
reformatting.
* exp_aggr.adb: Fix typo in comment.
2010-10-18 Javier Miranda <miranda@adacore.com>
* exp_util.adb (Side_Effect_Free): Code clean up.
......
......@@ -2,7 +2,7 @@
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . A S S E R T --
-- A D A . A S S E R T I O N S --
-- --
-- S p e c --
-- --
......
......@@ -86,9 +86,11 @@ package body Aspects is
(Name_Favor_Top_Level, Aspect_Favor_Top_Level),
(Name_Inline, Aspect_Inline),
(Name_Inline_Always, Aspect_Inline_Always),
(Name_Input, Aspect_Input),
(Name_Invariant, Aspect_Invariant),
(Name_Machine_Radix, Aspect_Machine_Radix),
(Name_Object_Size, Aspect_Object_Size),
(Name_Output, Aspect_Output),
(Name_Pack, Aspect_Pack),
(Name_Persistent_BSS, Aspect_Persistent_BSS),
(Name_Post, Aspect_Post),
......@@ -96,6 +98,7 @@ package body Aspects is
(Name_Predicate, Aspect_Predicate),
(Name_Preelaborable_Initialization, Aspect_Preelaborable_Initialization),
(Name_Pure_Function, Aspect_Pure_Function),
(Name_Read, Aspect_Read),
(Name_Shared, Aspect_Shared),
(Name_Size, Aspect_Size),
(Name_Storage_Pool, Aspect_Storage_Pool),
......@@ -112,7 +115,8 @@ package body Aspects is
(Name_Value_Size, Aspect_Value_Size),
(Name_Volatile, Aspect_Volatile),
(Name_Volatile_Components, Aspect_Volatile_Components),
(Name_Warnings, Aspect_Warnings));
(Name_Warnings, Aspect_Warnings),
(Name_Write, Aspect_Write));
-------------------------------------
-- Hash Table for Aspect Id Values --
......
......@@ -56,10 +56,12 @@ package Aspects is
Aspect_Favor_Top_Level, -- GNAT
Aspect_Inline,
Aspect_Inline_Always, -- GNAT
Aspect_Input,
Aspect_Invariant,
Aspect_Machine_Radix,
Aspect_No_Return,
Aspect_Object_Size, -- GNAT
Aspect_Output,
Aspect_Pack,
Aspect_Persistent_BSS, -- GNAT
Aspect_Post,
......@@ -67,6 +69,7 @@ package Aspects is
Aspect_Predicate, -- GNAT???
Aspect_Preelaborable_Initialization,
Aspect_Pure_Function, -- GNAT
Aspect_Read,
Aspect_Shared, -- GNAT (equivalent to Atomic)
Aspect_Size,
Aspect_Storage_Pool,
......@@ -83,7 +86,8 @@ package Aspects is
Aspect_Value_Size, -- GNAT
Aspect_Volatile,
Aspect_Volatile_Components,
Aspect_Warnings); -- GNAT
Aspect_Warnings,
Aspect_Write); -- GNAT
-- The following array indicates aspects that accept 'Class
......@@ -118,10 +122,12 @@ package Aspects is
Aspect_Favor_Top_Level => Optional,
Aspect_Inline => Optional,
Aspect_Inline_Always => Optional,
Aspect_Input => Name,
Aspect_Invariant => Expression,
Aspect_Machine_Radix => Expression,
Aspect_No_Return => Optional,
Aspect_Object_Size => Expression,
Aspect_Output => Name,
Aspect_Persistent_BSS => Optional,
Aspect_Pack => Optional,
Aspect_Post => Expression,
......@@ -129,6 +135,7 @@ package Aspects is
Aspect_Predicate => Expression,
Aspect_Preelaborable_Initialization => Optional,
Aspect_Pure_Function => Optional,
Aspect_Read => Name,
Aspect_Shared => Optional,
Aspect_Size => Expression,
Aspect_Storage_Pool => Name,
......@@ -145,7 +152,8 @@ package Aspects is
Aspect_Value_Size => Expression,
Aspect_Volatile => Optional,
Aspect_Volatile_Components => Optional,
Aspect_Warnings => Name);
Aspect_Warnings => Name,
Aspect_Write => Name);
function Get_Aspect_Id (Name : Name_Id) return Aspect_Id;
pragma Inline (Get_Aspect_Id);
......
......@@ -5421,7 +5421,7 @@ package body Exp_Aggr is
-- of the following form (c1 and c2 are inherited components)
-- (Exp with c3 => a, c4 => b)
-- ==> (c1 => Exp.c1, c2 => Exp.c2, c1 => a, c2 => b)
-- ==> (c1 => Exp.c1, c2 => Exp.c2, c3 => a, c4 => b)
else
Set_Etype (N, Typ);
......
......@@ -1462,6 +1462,10 @@ package body GNAT.Command_Line is
-- Start of processing for Get_Switches
begin
if Config = null then
return "";
end if;
Foreach (Config, Section => Section);
-- Adding relevant aliases
......
......@@ -794,6 +794,9 @@ package body System.Task_Primitives.Operations is
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for x86 systems
procedure Get_Stack_Bounds (Base : Address; Limit : Address);
pragma Import (C, Get_Stack_Bounds, "__gnat_get_stack_bounds");
-- Get stack boundaries
begin
Specific.Set (Self_ID);
Init_Float;
......@@ -806,6 +809,10 @@ package body System.Task_Primitives.Operations is
end if;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
Get_Stack_Bounds
(Self_ID.Common.Compiler_Data.Pri_Stack_Info.Base'Address,
Self_ID.Common.Compiler_Data.Pri_Stack_Info.Limit'Address);
end Enter_Task;
--------------
......
......@@ -86,8 +86,8 @@ package body Sem_Ch10 is
-- included in a standalone library.
procedure Check_Private_Child_Unit (N : Node_Id);
-- If a with_clause mentions a private child unit, the compilation
-- unit must be a member of the same family, as described in 10.1.2.
-- If a with_clause mentions a private child unit, the compilation unit
-- must be a member of the same family, as described in 10.1.2.
procedure Check_Stub_Level (N : Node_Id);
-- Verify that a stub is declared immediately within a compilation unit,
......@@ -126,8 +126,8 @@ package body Sem_Ch10 is
-- example through a limited_with clause in a parent unit.
procedure Install_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context and Install_Parents. Process only with_
-- and use_clauses for current unit and its library unit if any.
-- Subsidiary to Install_Context and Install_Parents. Process all with
-- and use clauses for current unit and its library unit if any.
procedure Install_Limited_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context. Process only limited with_clauses for
......@@ -187,18 +187,18 @@ package body Sem_Ch10 is
-- that all parents are removed in the nested case.
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id);
-- Reset all visibility flags on unit after compiling it, either as a
-- main unit or as a unit in the context.
-- Reset all visibility flags on unit after compiling it, either as a main
-- unit or as a unit in the context.
procedure Unchain (E : Entity_Id);
-- Remove single entity from visibility list
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
-- protected cases). N is the stub to be analyzed. Once the subunit
-- name is established, load and analyze. Nam is the non-overloadable
-- entity for which the proper body provides a completion. Subprogram
-- stubs are handled differently because they can be declarations.
-- protected cases). N is the stub to be analyzed. Once the subunit name
-- is established, load and analyze. Nam is the non-overloadable entity
-- for which the proper body provides a completion. Subprogram stubs are
-- handled differently because they can be declarations.
procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the
......@@ -272,11 +272,10 @@ package body Sem_Ch10 is
Clause : Node_Id;
Used : in out Boolean;
Used_Type_Or_Elab : in out Boolean);
-- Examine the context clauses of a package body, trying to match
-- the name entity of Clause with any list element. If the match
-- occurs on a use package clause, set Used to True, for a use
-- type clause, pragma Elaborate or pragma Elaborate_All, set
-- Used_Type_Or_Elab to True.
-- Examine the context clauses of a package body, trying to match the
-- name entity of Clause with any list element. If the match occurs
-- on a use package clause set Used to True, for a use type clause or
-- pragma Elaborate[_All], set Used_Type_Or_Elab to True.
procedure Process_Spec_Clauses
(Context_List : List_Id;
......
......@@ -870,13 +870,34 @@ package body Sem_Ch13 is
New_Occurrence_Of (E, Eloc),
Relocate_Node (Expr)),
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
Make_Identifier (Sloc (Id), Chars (Id)));
-- We don't have to play the delay game here, since the only
-- values are check names which don't get analyzed anyway.
Delay_Required := False;
-- Aspects corresponding to stream routines
when Aspect_Input |
Aspect_Output |
Aspect_Read |
Aspect_Write =>
-- Construct the attribute definition clause
Aitem :=
Make_Attribute_Definition_Clause (Loc,
Name => Ent,
Chars => Chars (Id),
Expression => Relocate_Node (Expr));
-- These are always delayed (typically the subprogram that
-- is referenced cannot have been declared yet, since it has
-- a reference to the type for which this aspect is defined.
Delay_Required := True;
-- Aspects corresponding to pragmas with two arguments, where
-- the second argument is a local name referring to the entity,
-- and the first argument is the aspect definition expression.
......
......@@ -99,7 +99,7 @@ package body Sem_Ch4 is
-- the operand of the operator node.
procedure Ambiguous_Operands (N : Node_Id);
-- for equality, membership, and comparison operators with overloaded
-- For equality, membership, and comparison operators with overloaded
-- arguments, list possible interpretations.
procedure Analyze_One_Call
......
......@@ -180,7 +180,7 @@ package body Sem_Ch6 is
-- entity with that name.
procedure Install_Entity (E : Entity_Id);
-- Make single entity visible. Used for generic formals as well
-- Make single entity visible (used for generic formals as well)
function Is_Non_Overriding_Operation
(Prev_E : Entity_Id;
......
......@@ -254,9 +254,8 @@ package body Sem_Ch7 is
end if;
if Is_Package_Or_Generic_Package (Spec_Id)
and then
(Scope (Spec_Id) = Standard_Standard
or else Is_Child_Unit (Spec_Id))
and then (Scope (Spec_Id) = Standard_Standard
or else Is_Child_Unit (Spec_Id))
and then not Unit_Requires_Body (Spec_Id)
then
if Ada_Version = Ada_83 then
......
......@@ -9451,7 +9451,10 @@ package body Sem_Util is
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
if Has_Pragma_Unmodified (Ent) then
-- Give warning if pragma unmodified given and we are
-- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then
Error_Msg_NE ("?pragma Unmodified given for &!", N, Ent);
end if;
......
......@@ -235,7 +235,7 @@ winflush_nt (void)
/* Does nothing as there is no problem under NT. */
}
#else
#else /* !RTX */
static void winflush_init (void);
......@@ -301,9 +301,27 @@ __gnat_is_windows_xp (void)
return is_win_xp;
}
#endif
#endif /* !RTX */
#endif
/* Get the bounds of the stack. The stack pointer is supposed to be
initialized to BASE when a thread is created and the stack can be extended
to LIMIT before reaching a guard page.
Note: for the main thread, the system automatically extend the stack, so
LIMIT is only the current limit. */
void
__gnat_get_stack_bounds (void **base, void **limit)
{
NT_TIB *tib;
/* We know that the first field of the TEB is the TIB. */
tib = (NT_TIB *)NtCurrentTeb ();
*base = tib->StackBase;
*limit = tib->StackLimit;
}
#endif /* !__MINGW32__ */
#else
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment