procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2011-08-29  Robert Dewar  <dewar@adacore.com>

	* impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting.

2011-08-29  Thomas Quinot  <quinot@adacore.com>

	* exp_dist.adb (TC_Rec_Add_Process_Element): For a choice with multiple
	values, we generate multiple triples of parameters in the TypeCode.
	Bump Choice_Index for each such triple so that a subsequent default
	choice is associated with the correct index in the typecode.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* a-cdlili.adb (Iterate): Initialize properly an iterator over a null
	container.
	(First, Last): Handle properly an iterator over a null container.

2011-08-29  Bob Duff  <duff@adacore.com>

	* sem_ch10.adb (Analyze_With_Clause,Install_Withed_Unit): Abandon
	processing if we run across a node with no Scope. This can happen if
	we're with-ing an library-level instance, and that instance got errors
	that caused "instantiation abandoned".
	* sem_util.adb (Unit_Declaration_Node): Make it more robust, by raising
	an exception instead of using Assert, so it won't go into an infinite
	loop, even when assertions are turned off.

2011-08-29  Ed Schonberg  <schonberg@adacore.com>

	* a-coorse.adb: Proper handling of empty ordered sets.

From-SVN: r178249
This commit is contained in:
Arnaud Charlet 2011-08-29 16:32:43 +02:00
parent 14f0f659ac
commit 1df4f514fa
10 changed files with 123 additions and 51 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
gcc/ada/ChangeLog
View file

@ -1,3 +1,34 @@
2011-08-29 Robert Dewar <dewar@adacore.com>
* impunit.adb, exp_ch4.adb, s-finmas.adb: Minor reformatting.
2011-08-29 Thomas Quinot <quinot@adacore.com>
* exp_dist.adb (TC_Rec_Add_Process_Element): For a choice with multiple
values, we generate multiple triples of parameters in the TypeCode.
Bump Choice_Index for each such triple so that a subsequent default
choice is associated with the correct index in the typecode.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* a-cdlili.adb (Iterate): Initialize properly an iterator over a null
container.
(First, Last): Handle properly an iterator over a null container.
2011-08-29 Bob Duff <duff@adacore.com>
* sem_ch10.adb (Analyze_With_Clause,Install_Withed_Unit): Abandon
processing if we run across a node with no Scope. This can happen if
we're with-ing an library-level instance, and that instance got errors
that caused "instantiation abandoned".
* sem_util.adb (Unit_Declaration_Node): Make it more robust, by raising
an exception instead of using Assert, so it won't go into an infinite
loop, even when assertions are turned off.
2011-08-29 Ed Schonberg <schonberg@adacore.com>
* a-coorse.adb: Proper handling of empty ordered sets.
2011-08-29 Johannes Kanig <kanig@adacore.com>
* debug.adb: Add comments.

21
gcc/ada/a-cdlili.adb
View file

@ -412,9 +412,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end First;
function First (Object : Iterator) return Cursor is
C : constant Cursor := (Object.Container, Object.Container.First);
begin
return C;
if Object.Container = null then
return No_Element;
else
return (Object.Container, Object.Container.First);
end if;
end First;
-------------------
@ -819,9 +822,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
function Iterate (Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Container.First);
begin
return It;
if Container.Length = 0 then
return Iterator'(null, null);
else
return Iterator'(Container'Unchecked_Access, Container.First);
end if;
end Iterate;
function Iterate (Container : List; Start : Cursor)
@ -846,9 +852,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Last;
function Last (Object : Iterator) return Cursor is
C : constant Cursor := (Object.Container, Object.Container.Last);
begin
return C;
if Object.Container = null then
return No_Element;
else
return (Object.Container, Object.Container.Last);
end if;
end Last;
------------------

19
gcc/ada/a-cidlli.adb
View file

@ -451,7 +451,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function First (Object : Iterator) return Cursor is
begin
return Cursor'(Object.Container, Object.Container.First);
if Object.Container = null then
return No_Element;
else
return Cursor'(Object.Container, Object.Container.First);
end if;
end First;
-------------------
@ -847,9 +851,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
(Container : List)
return List_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator := (Container'Unchecked_Access, Container.First);
begin
return It;
if Container.Length = 0 then
return Iterator'(null, null);
else
return Iterator'(Container'Unchecked_Access, Container.First);
end if;
end Iterate;
function Iterate
@ -877,11 +884,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
function Last (Object : Iterator) return Cursor is
begin
if Object.Container.Last = null then
if Object.Container = null then
return No_Element;
else
return Cursor'(Object.Container, Object.Container.Last);
end if;
return Cursor'(Object.Container, Object.Container.Last);
end Last;
------------------

21
gcc/ada/a-coorse.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2011, 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- --
@ -532,8 +532,13 @@ package body Ada.Containers.Ordered_Sets is
function First (Object : Iterator) return Cursor is
begin
return Cursor'(
Object.Container.all'Unrestricted_Access, Object.Container.Tree.First);
if Object.Container = null then
return No_Element;
else
return Cursor'(
Object.Container.all'Unrestricted_Access,
Object.Container.Tree.First);
end if;
end First;
-------------------
@ -1142,10 +1147,12 @@ package body Ada.Containers.Ordered_Sets is
function Iterate (Container : Set)
return Ordered_Set_Iterator_Interfaces.Reversible_Iterator'class
is
It : constant Iterator :=
(Container'Unchecked_Access, Container.Tree.First);
begin
return It;
if Container.Length = 0 then
return Iterator'(null, null);
else
return Iterator'(Container'Unchecked_Access, Container.Tree.First);
end if;
end Iterate;
function Iterate (Container : Set; Start : Cursor)
@ -1171,7 +1178,7 @@ package body Ada.Containers.Ordered_Sets is
function Last (Object : Iterator) return Cursor is
begin
if Object.Container.Tree.Last = null then
if Object.Container = null then
return No_Element;
end if;

3
gcc/ada/exp_ch4.adb
View file

@ -664,6 +664,8 @@ package body Exp_Ch4 is
-- Start of processing for Expand_Allocator_Expression
begin
-- WOuld be nice to comment the branches of this very long if ???
if Is_Tagged_Type (T)
or else Needs_Finalization (T)
then
@ -1136,6 +1138,7 @@ package body Exp_Ch4 is
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
Build_Allocate_Deallocate_Proc (N, True);

46
gcc/ada/exp_dist.adb
View file

@ -2084,8 +2084,7 @@ package body Exp_Dist is
is
N : constant Name_Id := Chars (Def);
Overload_Order : constant Int :=
Overload_Counter_Table.Get (N) + 1;
Overload_Order : constant Int := Overload_Counter_Table.Get (N) + 1;
begin
Overload_Counter_Table.Set (N, Overload_Order);
@ -10429,7 +10428,7 @@ package body Exp_Dist is
-- A variant part
declare
Variant_Part : declare
Disc_Type : constant Entity_Id := Etype (Name (Field));
Is_Enum : constant Boolean :=
@ -10451,6 +10450,8 @@ package body Exp_Dist is
Dummy_Counter : Int := 0;
Choice_Index : Int := 0;
-- Index of current choice in TypeCode, used to identify
-- it as the default choice if it is a "when others".
procedure Add_Params_For_Variant_Components;
-- Add a struct TypeCode and a corresponding member name
@ -10489,6 +10490,8 @@ package body Exp_Dist is
Add_String_Parameter (Name_Str, Union_TC_Params);
end Add_Params_For_Variant_Components;
-- Start of processing for Variant_Part
begin
Get_Name_String (U_Name);
Name_Str := String_From_Name_Buffer;
@ -10547,6 +10550,8 @@ package body Exp_Dist is
Add_Params_For_Variant_Components;
J := J + Uint_1;
end loop;
Choice_Index :=
Choice_Index + UI_To_Int (H - L) + 1;
end;
when N_Others_Choice =>
@ -10556,26 +10561,16 @@ package body Exp_Dist is
-- current choice index. This parameter is by
-- construction the 4th in Union_TC_Params.
declare
Default_Node : constant Node_Id :=
Pick (Union_TC_Params, 4);
New_Default_Node : constant Node_Id :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_TA_I32), Loc),
Parameter_Associations =>
New_List (
Make_Integer_Literal (Loc,
Intval => Choice_Index)));
begin
Insert_Before
(Default_Node, New_Default_Node);
Remove (Default_Node);
end;
Replace
(Pick (Union_TC_Params, 4),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_TA_I32), Loc),
Parameter_Associations =>
New_List (
Make_Integer_Literal (Loc,
Intval => Choice_Index))));
-- Add a placeholder member label for the
-- default case, which must have the
@ -10594,6 +10589,7 @@ package body Exp_Dist is
end;
Add_Params_For_Variant_Components;
Choice_Index := Choice_Index + 1;
when others =>
@ -10608,15 +10604,15 @@ package body Exp_Dist is
end;
Add_Params_For_Variant_Components;
Choice_Index := Choice_Index + 1;
end case;
Next (Choice);
Choice_Index := Choice_Index + 1;
end loop;
Next_Non_Pragma (Variant);
end loop;
end;
end Variant_Part;
end if;
end TC_Rec_Add_Process_Element;

6
gcc/ada/impunit.adb
View file

@ -524,9 +524,9 @@ package body Impunit is
"a-synbar", -- Ada.Synchronous_Barriers
"a-undesu", -- Ada.Unchecked_Deallocate_Subpool
-----------------------------------------
-- GNAT Defined Additions to Ada 20012 --
-----------------------------------------
----------------------------------------
-- GNAT Defined Additions to Ada 2012 --
----------------------------------------
"a-cofove", -- Ada.Containers.Formal_Vectors
"a-cfdlli", -- Ada.Containers.Formal_Doubly_Linked_Lists

5
gcc/ada/s-finmas.adb
View file

@ -29,7 +29,8 @@
-- --
------------------------------------------------------------------------------
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Exceptions; use Ada.Exceptions;
with System.Address_Image;
with System.HTable; use System.HTable;
with System.IO; use System.IO;
@ -241,12 +242,10 @@ package body System.Finalization_Masters is
(Obj : System.Address) return Finalize_Address_Ptr
is
Result : Finalize_Address_Ptr;
begin
Lock_Task.all;
Result := Finalize_Address_Table.Get (Obj);
Unlock_Task.all;
return Result;
end Finalize_Address;

14
gcc/ada/sem_ch10.adb
View file

@ -2585,6 +2585,13 @@ package body Sem_Ch10 is
if Par_Name /= Standard_Standard then
Par_Name := Scope (Par_Name);
end if;
-- Abandon processing in case of previous errors
if No (Par_Name) then
pragma Assert (Serious_Errors_Detected /= 0);
return;
end if;
end loop;
if Present (Entity (Pref))
@ -5034,6 +5041,13 @@ package body Sem_Ch10 is
("instantiation depends on itself", Name (With_Clause));
elsif not Is_Visible_Child_Unit (Uname) then
-- Abandon processing in case of previous errors
if No (Scope (Uname)) then
pragma Assert (Serious_Errors_Detected /= 0);
return;
end if;
Set_Is_Visible_Child_Unit (Uname);
-- If the child unit appears in the context of its parent, it is

8
gcc/ada/sem_util.adb
View file

@ -12638,7 +12638,13 @@ package body Sem_Util is
and then Nkind (N) not in N_Generic_Renaming_Declaration
loop
N := Parent (N);
pragma Assert (Present (N));
-- We don't use Assert here, because that causes an infinite loop
-- when assertions are turned off. Better to crash.
if No (N) then
raise Program_Error;
end if;
end loop;
return N;