+2014-02-20 Robert Dewar <dewar@adacore.com>
+
+ * a-crbtgk.adb, a-cihama.adb, a-coinve.adb, a-ciorse.adb, a-crbtgo.adb,
+ a-cidlli.adb, a-cimutr.adb, a-cihase.adb, a-cohama.adb, a-coorse.adb,
+ a-chtgke.adb, a-chtgop.adb, a-comutr.adb, a-ciorma.adb, a-cobove.adb,
+ a-convec.adb, a-cohase.adb, a-chtgbk.adb, a-chtgbo.adb: Minor
+ reformatting.
+
+2014-02-20 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads: Minor: Remove incorrect comment.
+
+2014-02-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_elab.adb (Check_Elab_Assign): Clearer warning message.
+
+2014-02-20 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cborma.adb (Assign): When creating a node without a specified
+ element, insert an uninitialized element in the map, because
+ the instance may provide an element type with a default
+ initialization, e.g a scalar with a Default_Value aspect.
+ * a-cbhama.adb (Assign_Key): Remove useless Allocate procedure.
+ (Insert): In the version without explicit element, provide an
+ uninitialized element, as above.
+ * a-cbdlli.adb (Append): In the version without explicit element,
+ provide an uninitalized element, as above.
+ (Allocate): Remove unused version.
+
2014-02-20 Robert Dewar <dewar@adacore.com>
* sem_elab.adb: Minor code reorganization (use Nkind_In).
New_Item : Element_Type;
New_Node : out Count_Type);
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type);
-
procedure Allocate
(Container : in out List;
Stream : not null access Root_Stream_Type'Class;
end if;
end Allocate;
- procedure Allocate
- (Container : in out List;
- New_Node : out Count_Type)
- is
- N : Node_Array renames Container.Nodes;
-
- begin
- if Container.Free >= 0 then
- New_Node := Container.Free;
- Container.Free := N (New_Node).Next;
-
- else
- -- As explained above, a negative free store value means that the
- -- links for the nodes in the free store have not been initialized.
-
- New_Node := abs Container.Free;
- Container.Free := Container.Free - 1;
- end if;
- end Allocate;
-
------------
-- Append --
------------
Position : out Cursor;
Count : Count_Type := 1)
is
- New_Node : Count_Type;
+ New_Item : Element_Type; -- Default initialized.
+ pragma Warnings (Off, New_Item);
begin
- if Before.Container /= null then
- if Before.Container /= Container'Unrestricted_Access then
- raise Program_Error with
- "Before cursor designates wrong list";
- end if;
-
- pragma Assert (Vet (Before), "bad cursor in Insert");
- end if;
-
- if Count = 0 then
- Position := Before;
- return;
- end if;
-
- if Container.Length > Container.Capacity - Count then
- raise Constraint_Error with "new length exceeds capacity";
- end if;
-
- if Container.Busy > 0 then
- raise Program_Error with
- "attempt to tamper with cursors (list is busy)";
- end if;
-
- Allocate (Container, New_Node => New_Node);
- Insert_Internal (Container, Before.Node, New_Node);
- Position := Cursor'(Container'Unchecked_Access, New_Node);
+ -- There is no explicit element provided, but in an instance the
+ -- element type may be a scalar with a Default_Value aspect, or a
+ -- composite type with such a scalar component, so we insert the
+ -- specified number of possibly initialized elements at the given
+ -- position.
- for Index in Count_Type'(2) .. Count loop
- Allocate (Container, New_Node => New_Node);
- Insert_Internal (Container, Before.Node, New_Node);
- end loop;
+ Insert (Container, Before, New_Item, Position, Count);
end Insert;
---------------------
-----------------
procedure Assign_Key (Node : in out Node_Type) is
+ New_Item : Element_Type;
+ pragma Warnings (Off, New_Item);
+ -- Default-initialized element (ok to reference, see below)
+
begin
Node.Key := Key;
- -- Note that we do not also assign the element component of the node
- -- here, because this version of Insert does not accept an element
- -- parameter.
+ -- There is no explicit element provided, but in an instance the
+ -- element type may be a scalar with a Default_Value aspect, or
+ -- a composite type with such a scalar component, so we insert
+ -- a possibly initialized element under the given key.
- -- Node.Element := New_Item;
- -- What is this deleted code about???
+ Node.Element := New_Item;
end Assign_Key;
--------------
------------
procedure Assign (Node : in out Node_Type) is
+ New_Item : Element_Type;
+ pragma Warnings (Off, New_Item);
+ -- Default-initialized element (ok to reference, see below)
+
begin
Node.Key := Key;
- -- Were this insertion operation to accept an element parameter, this
- -- is the point where the element value would be used, to update the
- -- element component of the new node. However, this insertion
- -- operation is special, in the sense that it does not accept an
- -- element parameter. Rather, this version of Insert allocates a node
- -- (inserting it among the active nodes of the container in the
- -- normal way, with the node's position being determined by the Key),
- -- and passes back a cursor designating the node. It is then up to
- -- the caller to assign a value to the node's element.
-
- -- Node.Element := New_Item;
+ -- There is no explicit element provided, but in an instance the
+ -- element type may be a scalar with a Default_Value aspect, or
+ -- a composite type with such a scalar component, so we insert
+ -- a possibly initialized element under the given key.
+
+ Node.Element := New_Item;
end Assign;
--------------
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
declare
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
+
begin
B := B + 1;
L := L + 1;
B := B - 1;
L := L - 1;
+
exception
when others =>
B := B - 1;
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
L_Node := Next (L.Nodes (L_Node));
if L_Node = 0 then
+
-- We have exhausted the nodes in this bucket
if N = 0 then
LR := LR - 1;
return Result;
+
exception
when others =>
BL := BL - 1;
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
declare
B : Natural renames HT.Busy;
L : Natural renames HT.Lock;
+
begin
B := B + 1;
L := L + 1;
B := B - 1;
L := L - 1;
+
exception
when others =>
B := B - 1;
L := L - 1;
return Result;
+
exception
when others =>
B := B - 1;
LR := LR - 1;
return Result;
+
exception
when others =>
BL := BL - 1;
pragma Assert (L > 0);
L := L - 1;
end loop;
+
exception
when others =>
+
-- If there's an error computing a hash value during a
- -- rehash, then AI-302 says the nodes "become lost." The
+ -- rehash, then AI-302 says the nodes "become lost." The
-- issue is whether to actually deallocate these lost nodes,
- -- since they might be designated by extant cursors. Here
+ -- since they might be designated by extant cursors. Here
-- we decide to deallocate the nodes, since it's better to
-- solve real problems (storage consumption) rather than
-- imaginary ones (the user might, or might not, dereference
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Is_Sorted;
B := B - 1;
L := L - 1;
+
exception
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Reverse_Find;
function Copy_Node (Node : Node_Access) return Node_Access is
K : Key_Access := new Key_Type'(Node.Key.all);
E : Element_Access;
-
begin
E := new Element_Type'(Node.Element.all);
return new Node_Type'(K, E, null);
-
exception
when others =>
Free_Key (K);
begin
Free_Key (X.Key);
+
exception
when others =>
X.Key := null;
exception
when others =>
X.Element := null;
-
Deallocate (X);
raise;
end;
begin
Process (K, E);
+
exception
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
begin
Bucket := new Node_Type'(Tgt, Bucket);
+
exception
when others =>
Free_Element (Tgt);
begin
Iterate (Left.HT);
+
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
begin
Free_Element (X.Element);
+
exception
when others =>
X.Element := null;
begin
Bucket := new Node_Type'(Tgt, Bucket);
+
exception
when others =>
Free_Element (Tgt);
begin
Iterate (Left.HT);
+
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
begin
Iterate (Right_HT);
+
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
LL := LL - 1;
LB := LB - 1;
+
exception
when others =>
RL := RL - 1;
Indx := HT_Ops.Index (HT, Position.Node);
Process (E);
Eq := Equivalent_Keys (K, Key (E));
+
exception
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2013, 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- --
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
end Update_Element;
Color => Source.Color,
Key => K,
Element => E);
+
exception
when others =>
Free_Key (K);
begin
Local_Iterate (Container.Tree);
+
exception
when others =>
B := B - 1;
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
-
begin
Process (K, E);
exception
declare
K : Key_Type renames Position.Node.Key.all;
E : Element_Type renames Position.Node.Element.all;
-
begin
Process (K, E);
-
exception
when others =>
L := L - 1;
Right => null,
Color => Source.Color,
Element => Element);
+
exception
when others =>
Free_Element (Element);
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Find_Index;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Is_Sorted;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Sort;
else
return Cursor'(Container'Unrestricted_Access, Result);
end if;
+
exception
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Reverse_Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Reverse_Find_Index;
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
-
begin
Process (K, E);
exception
declare
K : Key_Type renames Position.Node.Key;
E : Element_Type renames Position.Node.Element;
-
begin
Process (K, E);
-
exception
when others =>
L := L - 1;
return Node_Access
is
Node : Node_Access := new Node_Type;
-
begin
Element_Type'Read (Stream, Node.Element);
return Node;
begin
Iterate (Left_HT);
+
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
begin
Iterate (Right_HT);
+
exception
when others =>
HT_Ops.Free_Hash_Table (Buckets);
L := L - 1;
B := B - 1;
+
exception
when others =>
L := L - 1;
LL := LL - 1;
LB := LB - 1;
+
exception
when others =>
RL := RL - 1;
LR := LR - 1;
return Result;
+
exception
when others =>
BL := BL - 1;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Find_Index;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Is_Sorted;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Sort;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2013, 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- --
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
end Query_Element;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
end Update_Element;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Find_Index;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Is_Sorted;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Sort;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end;
end Reverse_Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Reverse_Find_Index;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Ceiling;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Find;
when others =>
B := B - 1;
L := L - 1;
+
raise;
end Floor;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
when others =>
L := L - 1;
B := B - 1;
+
raise;
end;
end loop;
return Target_Root;
+
exception
when others =>
Delete_Tree (Target_Root);
pragma Warnings (static_string_EXPRESSION [,REASON]);
pragma Warnings (On | Off, static_string_EXPRESSION [,REASON]);
-REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
+REASON ::= Reason => STRING_LITERAL @{& STRING_LITERAL@}
@end smallexample
@noindent
-- Similar to the procedure above, but saves the output of the command to
-- a file with the name Output_File.
--
- -- Success is set to True if the command is executed and its output
- -- successfully written to the file. Invalid_Pid is returned if the output
- -- file could not be created or if the program could not be spawned
- -- successfully.
+ -- Invalid_Pid is returned if the output file could not be created or if
+ -- the program could not be spawned successfully.
--
-- Spawning processes from tasking programs is not recommended. See
-- "NOTE: Spawn in tasking programs" below.
Error_Msg_Sloc := Sloc (Ent);
Error_Msg_NE
- ("??elaboration code may access& before it is initialized",
+ ("??& can be accessed by clients before this initialization",
N, Ent);
Error_Msg_NE
- ("\??suggest adding pragma Elaborate_Body to spec of &",
- N, Scop);
- Error_Msg_N
- ("\??or an explicit initialization could be added #", N);
+ ("\??add Elaborate_Body to spec to ensure & is initialized",
+ N, Ent);
end if;
if not All_Errors_Mode then
projects / thirdparty / gcc.git / commitdiff
