+2012-05-15 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch7.adb, exp_ch11.adb, exp_ch11.ads: Minor reformatting.
+
+2012-05-15 Thomas Quinot <quinot@adacore.com>
+
+ * sem_res.adb (Resolve): Enforce E.2.2(11/2) and E.2.2(12) for
+ 'Unrestricted_Access and 'Unchecked_Access (not just 'Access):
+ even in those cases, a remote access type may only designate a
+ remote subprogram.
+
+2012-05-15 Thomas Quinot <quinot@adacore.com>
+
+ * sem_util.adb, sem_util.ads, sem_cat.adb: Minor refactoring.
+ (Enclosing_Lib_Unit_Node): Rename to Enclosing_Comp_Unit_Node.
+
+2012-05-15 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove obsolete
+ checks on nested inlined subprograms.
+
+2012-05-15 Tristan Gingold <gingold@adacore.com>
+
+ * fe.h (Get_RT_Exception_Name): Declare.
+
+2012-05-15 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c (db_region_for): Use %p + cast to avoid warnings.
+ (get_region_description_for): Likewise.
+ (db_action_for): Likewise.
+ (get_call_site_action_for): Likewise.
+ (get_ttype_entry_for): Remove useless 'const'.
+ (PERSONALITY_FUNCTION): Add ATTRIBUTE_UNUSED on uw_exception_class.
+
+2012-05-15 Tristan Gingold <gingold@adacore.com>
+
+ * a-exextr.adb (Unhandled_Exception_Terminate): Save occurrence
+ on the stack to avoid a dynamic memory allocation.
+
+2012-05-15 Bob Duff <duff@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Timed_Entry_Call): Move initialization of
+ E_Stats and D_Stats after Process_Statements_For_Controlled_Objects,
+ because those calls can destroy the Statements list.
+
2012-05-15 Tristan Gingold <gingold@adacore.com>
* fe.h (Get_RT_Exception_Name): Define.
-- --
-- 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- --
-----------------------------------
procedure Unhandled_Exception_Terminate is
- Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all);
+ Excep : Exception_Occurrence;
-- This occurrence will be used to display a message after finalization.
-- It is necessary to save a copy here, or else the designated value
-- could be overwritten if an exception is raised during finalization
-- (even if that exception is caught).
begin
- Last_Chance_Handler (Excep.all);
+ Save_Occurrence (Excep, Get_Current_Excep.all.all);
+ Last_Chance_Handler (Excep);
end Unhandled_Exception_Terminate;
------------------------------------
-- case it will end up in the block statements, even though it
-- is not there now.
- if Is_List_Member (N)
- and then (List_Containing (N) = Statements (P)
- or else
- List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
- or else
- List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
- then
- -- Loop through exception handlers
+ if Is_List_Member (N) then
+ declare
+ LCN : constant List_Id := List_Containing (N);
- H := First (Exception_Handlers (P));
- while Present (H) loop
+ begin
+ if LCN = Statements (P)
+ or else
+ LCN = SSE.Actions_To_Be_Wrapped_Before
+ or else
+ LCN = SSE.Actions_To_Be_Wrapped_After
+ then
+ -- Loop through exception handlers
- -- Guard against other constructs appearing in the list of
- -- exception handlers.
+ H := First (Exception_Handlers (P));
+ while Present (H) loop
- if Nkind (H) = N_Exception_Handler then
+ -- Guard against other constructs appearing in the
+ -- list of exception handlers.
- -- Loop through choices in one handler
+ if Nkind (H) = N_Exception_Handler then
- C := First (Exception_Choices (H));
- while Present (C) loop
+ -- Loop through choices in one handler
- -- Deal with others case
+ C := First (Exception_Choices (H));
+ while Present (C) loop
- if Nkind (C) = N_Others_Choice then
+ -- Deal with others case
- -- Matching others handler, but we need to ensure
- -- there is no choice parameter. If there is, then
- -- we don't have a local handler after all (since
- -- we do not allow choice parameters for local
- -- handlers).
+ if Nkind (C) = N_Others_Choice then
- if No (Choice_Parameter (H)) then
- return H;
- else
- return Empty;
- end if;
+ -- Matching others handler, but we need
+ -- to ensure there is no choice parameter.
+ -- If there is, then we don't have a local
+ -- handler after all (since we do not allow
+ -- choice parameters for local handlers).
- -- If not others must be entity name
+ if No (Choice_Parameter (H)) then
+ return H;
+ else
+ return Empty;
+ end if;
- elsif Nkind (C) /= N_Others_Choice then
- pragma Assert (Is_Entity_Name (C));
- pragma Assert (Present (Entity (C)));
+ -- If not others must be entity name
- -- Get exception being handled, dealing with
- -- renaming.
+ elsif Nkind (C) /= N_Others_Choice then
+ pragma Assert (Is_Entity_Name (C));
+ pragma Assert (Present (Entity (C)));
- EHandle := Get_Renamed_Entity (Entity (C));
+ -- Get exception being handled, dealing with
+ -- renaming.
- -- If match, then check choice parameter
+ EHandle := Get_Renamed_Entity (Entity (C));
- if ERaise = EHandle then
- if No (Choice_Parameter (H)) then
- return H;
- else
- return Empty;
+ -- If match, then check choice parameter
+
+ if ERaise = EHandle then
+ if No (Choice_Parameter (H)) then
+ return H;
+ else
+ return Empty;
+ end if;
+ end if;
end if;
- end if;
+
+ Next (C);
+ end loop;
end if;
- Next (C);
+ Next (H);
end loop;
end if;
-
- Next (H);
- end loop;
+ end;
end if;
end if;
-- the exception entity to be passed to Local_Raise.
procedure Get_RT_Exception_Name (Code : RT_Exception_Code);
- -- This procedure is provided for use by the back end to get in the
- -- name of the Rcheck procedure for Code. The name is appended to
- -- Namet.Name_Buffer, without the __gnat_rcheck_ prefix.
+ -- This procedure is provided for use by the back end to obtain the name of
+ -- the Rcheck procedure for Code. The name is appended to Namet.Name_Buffer
+ -- without the __gnat_rcheck_ prefix.
function Is_Non_Ada_Error (E : Entity_Id) return Boolean;
-- This function is provided for Gigi use. It returns True if operating on
pragma Assert (Present (Data.Raised_Id));
if Exception_Extra_Info
- or else (For_Library and then not Restricted_Profile)
+ or else (For_Library and not Restricted_Profile)
then
if Exception_Extra_Info then
+
-- Generate:
-- Get_Current_Excep.all
Name =>
Make_Explicit_Dereference (Data.Loc,
Prefix =>
- New_Reference_To (RTE (RE_Get_Current_Excep),
- Data.Loc)));
+ New_Reference_To
+ (RTE (RE_Get_Current_Excep), Data.Loc)));
+
else
-- Generate:
if For_Library and then not Restricted_Profile then
Proc_To_Call := RTE (RE_Save_Library_Occurrence);
Actuals := New_List (Except);
+
else
Proc_To_Call := RTE (RE_Save_Occurrence);
-- The dereference occurs only when Exception_Extra_Info is true,
-- and therefore Except is not null.
- Actuals := New_List (
- New_Reference_To (Data.E_Id, Data.Loc),
- Make_Explicit_Dereference (Data.Loc, Except));
+ Actuals :=
+ New_List (
+ New_Reference_To (Data.E_Id, Data.Loc),
+ Make_Explicit_Dereference (Data.Loc, Except));
end if;
-- Generate:
A_Expr := New_Reference_To (RTE (RE_Triggered_By_Abort), Loc);
-- Generate:
+
-- Abort_Id : constant Boolean := <A_Expr>;
Append_To (Decls,
Data.E_Id := Make_Temporary (Loc, 'E');
-- Generate:
+
-- E_Id : Exception_Occurrence;
E_Decl :=
end if;
-- Generate:
+
-- Raised_Id : Boolean := False;
Append_To (Decls,
end if;
-- Generate:
+
-- Raised_Id and then not Abort_Id
-- <or>
-- Raised_Id
end if;
-- Generate:
+
-- if Raised_Id and then not Abort_Id then
-- Raise_From_Controlled_Operation (E_Id);
-- <or>
E_Call : Node_Id :=
Entry_Call_Statement (Entry_Call_Alternative (N));
- E_Stats : constant List_Id :=
- Statements (Entry_Call_Alternative (N));
+ E_Stats : List_Id; -- statements after entry call
D_Stat : Node_Id :=
Delay_Statement (Delay_Alternative (N));
- D_Stats : constant List_Id :=
- Statements (Delay_Alternative (N));
+ D_Stats : List_Id; -- statements after "delay ..."
Actuals : List_Id;
Blk_Typ : Entity_Id;
Process_Statements_For_Controlled_Objects (Entry_Call_Alternative (N));
Process_Statements_For_Controlled_Objects (Delay_Alternative (N));
+ -- Must fetch E_Stats/D_Stats after above "Process_...", because it
+ -- might modify them.
+
+ E_Stats := Statements (Entry_Call_Alternative (N));
+ D_Stats := Statements (Delay_Alternative (N));
+
-- The arguments in the call may require dynamic allocation, and the
-- call statement may have been transformed into a block. The block
-- may contain additional declarations for internal entities, and the
extern Entity_Id Get_Local_Raise_Call_Entity (void);
extern Entity_Id Get_RT_Exception_Entity (int);
+extern void Get_RT_Exception_Name (int);
/* exp_code: */
* *
* C Implementation File *
* *
- * 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- *
ip = get_ip_from_context (uw_context);
- db (DB_REGIONS, "For ip @ 0x%08x => ", ip);
+ db (DB_REGIONS, "For ip @ %p => ", (void *)ip);
if (region->lsda)
- db (DB_REGIONS, "lsda @ 0x%x", region->lsda);
+ db (DB_REGIONS, "lsda @ %p", (void *)region->lsda);
else
db (DB_REGIONS, "no lsda");
/* Retrieve the ttype entry associated with FILTER in the REGION's
ttype table. */
-static const _Unwind_Ptr
+static _Unwind_Ptr
get_ttype_entry_for (region_descriptor *region, long filter)
{
_Unwind_Ptr ttype_entry;
return;
/* Parse the lsda and fill the region descriptor. */
- p = (char *)region->lsda;
+ p = (const unsigned char *)region->lsda;
region->base = _Unwind_GetRegionStart (uw_context);
{
_Unwind_Ptr ip = get_ip_from_context (uw_context);
- db (DB_ACTIONS, "For ip @ 0x%08x => ", ip);
+ db (DB_ACTIONS, "For ip @ %p => ", (void *)ip);
switch (action->kind)
{
case unknown:
- db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n",
- action->landing_pad, action->table_entry);
+ db (DB_ACTIONS, "lpad @ %p, record @ %p\n",
+ (void *) action->landing_pad, action->table_entry);
break;
case nothing:
break;
case handler:
- db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter);
+ db (DB_ACTIONS, "Handler, filter = %d\n", (int) action->ttype_filter);
break;
default:
p = read_uleb128 (p, &cs_action);
db (DB_CSITE,
- "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n",
- region->base+cs_start, cs_start, cs_len,
- region->lp_base+cs_lp, cs_lp);
+ "c_site @ %p (+%p), len = %p, lpad @ %p (+%p)\n",
+ (void *)region->base + cs_start, (void *)cs_start, (void *)cs_len,
+ (void *)region->lp_base + cs_lp, (void *)cs_lp);
/* The table is sorted, so if we've passed the IP, stop. */
if (ip < region->base + cs_start)
_Unwind_Reason_Code
PERSONALITY_FUNCTION (version_arg_t version_arg,
phases_arg_t phases_arg,
- _Unwind_Exception_Class uw_exception_class,
+ _Unwind_Exception_Class uw_exception_class
+ ATTRIBUTE_UNUSED,
_Unwind_Exception *uw_exception,
_Unwind_Context *uw_context)
{
if Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)))
and then
- Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E)
+ Enclosing_Comp_Unit_Node (N) /= Enclosing_Comp_Unit_Node (E)
and then (Is_Preelaborated (Scope (E))
or else Is_Pure (Scope (E))
or else (Present (Renamed_Object (E))
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Conformant : Boolean;
HSS : Node_Id;
- P_Ent : Entity_Id;
Prot_Typ : Entity_Id := Empty;
Spec_Id : Entity_Id;
Spec_Decl : Node_Id := Empty;
end if;
end if;
- -- Do not inline any subprogram that contains nested subprograms, since
- -- the backend inlining circuit seems to generate uninitialized
- -- references in this case. We know this happens in the case of front
- -- end ZCX support, but it also appears it can happen in other cases as
- -- well. The backend often rejects attempts to inline in the case of
- -- nested procedures anyway, so little if anything is lost by this.
- -- Note that this is test is for the benefit of the back-end. There is
- -- a separate test for front-end inlining that also rejects nested
- -- subprograms.
-
- -- Do not do this test if errors have been detected, because in some
- -- error cases, this code blows up, and we don't need it anyway if
- -- there have been errors, since we won't get to the linker anyway.
-
- if Comes_From_Source (Body_Id)
- and then Serious_Errors_Detected = 0
- and then not Debug_Flag_Dot_K
- then
- P_Ent := Body_Id;
- loop
- P_Ent := Scope (P_Ent);
- exit when No (P_Ent) or else P_Ent = Standard_Standard;
-
- if Is_Subprogram (P_Ent) then
- Set_Is_Inlined (P_Ent, False);
-
- if Comes_From_Source (P_Ent)
- and then Has_Pragma_Inline (P_Ent)
- then
- Cannot_Inline
- ("cannot inline& (nested subprogram)?",
- N, P_Ent);
- end if;
- end if;
- end loop;
- end if;
+ -- Previously we scanned the body to look for nested subprograms, and
+ -- rejected an inline directive if nested subprograms were present,
+ -- because the back-end would generate conflicting symbols for the
+ -- nested bodies. This is now unecessary.
-- Look ahead to recognize a pragma inline that appears after the body
-- Prefix (N) must statically denote a remote subprogram
-- declared in a package specification.
- if Attr = Attribute_Access then
+ if Attr = Attribute_Access or else
+ Attr = Attribute_Unchecked_Access or else
+ Attr = Attribute_Unrestricted_Access
+ then
Decl := Unit_Declaration_Node (Entity (Pref));
if Nkind (Decl) = N_Subprogram_Body then
("prefix must statically denote a remote subprogram ",
N);
end if;
- end if;
- -- If we are generating code for a distributed program.
- -- perform semantic checks against the corresponding
- -- remote entities.
+ -- If we are generating code in distributed mode, perform
+ -- semantic checks against corresponding remote entities.
- if (Attr = Attribute_Access or else
- Attr = Attribute_Unchecked_Access or else
- Attr = Attribute_Unrestricted_Access)
- and then Full_Expander_Active
- and then Get_PCS_Name /= Name_No_DSA
- then
- Check_Subtype_Conformant
- (New_Id => Entity (Prefix (N)),
- Old_Id => Designated_Type
- (Corresponding_Remote_Type (Typ)),
- Err_Loc => N);
-
- if Is_Remote then
- Process_Remote_AST_Attribute (N, Typ);
+ if Full_Expander_Active
+ and then Get_PCS_Name /= Name_No_DSA
+ then
+ Check_Subtype_Conformant
+ (New_Id => Entity (Prefix (N)),
+ Old_Id => Designated_Type
+ (Corresponding_Remote_Type (Typ)),
+ Err_Loc => N);
+
+ if Is_Remote then
+ Process_Remote_AST_Attribute (N, Typ);
+ end if;
end if;
end if;
end if;
return Unit_Entity;
end Enclosing_Lib_Unit_Entity;
- -----------------------------
- -- Enclosing_Lib_Unit_Node --
- -----------------------------
+ ------------------------------
+ -- Enclosing_Comp_Unit_Node --
+ ------------------------------
- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
+ function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id is
Current_Node : Node_Id;
begin
end if;
return Current_Node;
- end Enclosing_Lib_Unit_Node;
+ end Enclosing_Comp_Unit_Node;
-----------------------
-- Enclosing_Package --
-- root of the current scope (which must not be Standard_Standard, and the
-- caller is responsible for ensuring this condition).
- function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id;
+ function Enclosing_Comp_Unit_Node (N : Node_Id) return Node_Id;
-- Returns the enclosing N_Compilation_Unit Node that is the root of a
-- subtree containing N.
projects / platform / upstream / gcc.git / commitdiff