* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@178249
138bc75d-0d04-0410-961f-
82ee72b054a4
+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.
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;
-------------------
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)
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;
------------------
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;
-------------------
(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
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;
------------------
-- --
-- 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- --
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;
-------------------
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)
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;
-- 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
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
+
else
Build_Allocate_Deallocate_Proc (N, True);
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);
-- A variant part
- declare
+ Variant_Part : declare
Disc_Type : constant Entity_Id := Etype (Name (Field));
Is_Enum : constant Boolean :=
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
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;
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 =>
-- 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
end;
Add_Params_For_Variant_Components;
+ Choice_Index := Choice_Index + 1;
when others =>
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;
"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
-- --
------------------------------------------------------------------------------
-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;
(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;
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))
("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
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;
OSDN Git Service
