+2011-12-21 Vincent Celier <celier@adacore.com>
+
+ * prj-nmsc.adb (Report_No_Sources): Remove argument Lang. Report
+ no sources even for languages that are not allowed.
+ (Add_Source): Get the source even when the language is not allowed.
+
+2011-12-21 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch6.adb (Process_Formals): Add defensive code.
+
+2011-12-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch7.adb, sem_ch13.adb (Analyze_Package_Specification): Build the
+ invariant procedure of a type declaration that is a completion and has
+ aspect specifications.
+ (Build_Invariant_Procedure): If the procedure is built for a
+ type declaration that is a completion, analyze body expliitly
+ because all private declarations have been already analyzed.
+
+2011-12-21 Claire Dross <dross@adacore.com>
+
+ * a-cfdlli.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb,
+ a-cofove.adb: Minor reformating on formal containers
+
+2011-12-21 Vincent Celier <celier@adacore.com>
+
+ * makeutl.adb (Mains.Complete_Mains.Do_Complete): Remove
+ any main that is not in the list of restricted languages.
+ (Insert_Project_Sources.Do_Insert): Only add sources of languages
+ in the list of restricted languages.
+
+2011-12-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Valid_Conversion): A type conversion is valid when
+ the target type is an anonymous access type and the operand is a
+ rewriting of an allocator. The conversion is typically inserted
+ when the designated type is an interface.
+
+2011-12-21 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Establish_Task_Master): If the enclosing block
+ has no declarations, create new declarative list for it.
+
+2011-12-21 Matthew Heaney <heaney@adacore.com>
+
+ * a-rbtgbk.adb (Generic_Conditional_Insert): Fixed incorrect comment.
+
2011-12-21 Yannick Moy <moy@adacore.com>
* sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
pragma Assert
(Vet (Container, Position), "bad cursor in Replace_Element");
- declare
- N : Node_Array renames Container.Nodes;
- begin
- N (Position.Node).Element := New_Item;
- end;
-
- -- Above is peculiar, why not simply
- -- Container.Nodes (Position.Node).Element := New_Item ???
-
+ Container.Nodes (Position.Node).Element := New_Item;
end Replace_Element;
----------------------
-- Start of processing for Union
begin
-
if Target'Address = Source'Address then
return;
end if;
X : Count_Type;
begin
-
Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
if X = 0 then
N : Nodes_Type renames Container.Nodes;
begin
-
if Position.Node = 0 then
raise Constraint_Error with
"Position cursor equals No_Element";
Element : Element_Type))
is
begin
-
if not Has_Element (Container, Position) then
raise Constraint_Error with
"Position cursor of Query_Element has no element";
pragma Assert (Vet (Container, Position.Node),
"bad cursor in Element");
- declare
- N : Tree_Types.Nodes_Type renames Container.Nodes;
- begin
- return N (Position.Node).Element;
- end;
+ return Container.Nodes (Position.Node).Element;
end Element;
-------------------------
Last : constant Index_Type := Last_Index (Container);
begin
-
K := Count_Type (Int (Index) - Int (No_Index));
for Indx in Index .. Last loop
if Get_Element (Container, K) = Item then
procedure Merge (Target, Source : in out Vector) is
begin
-
declare
TA : Elements_Array renames Target.Elements;
SA : Elements_Array renames Source.Elements;
N : constant Count_Type := Length (Source);
begin
-
if Target'Address = Source'Address then
return;
end if;
New_Item : Element_Type)
is
begin
-
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
New_Item : Element_Type)
is
begin
-
if not Position.Valid then
raise Constraint_Error with "Position cursor has no element";
end if;
L : Natural renames Container.Lock;
begin
-
if Index > Container.Last then
raise Constraint_Error with "Index is out of range";
end if;
-- --
-- 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- --
N : Nodes_Type renames Tree.Nodes;
begin
- Y := 0;
+ -- This is a "conditional" insertion, meaning that the insertion request
+ -- can "fail" in the sense that no new node is created. If the Key is
+ -- equivalent to an existing node, then we return the existing node and
+ -- Inserted is set to False. Otherwise, we allocate a new node (via
+ -- Insert_Post) and Inserted is set to True.
+
+ -- Note that we are testing for equivalence here, not equality. Key must
+ -- be strictly less than its next neighbor, and strictly greater than
+ -- its previous neighbor, in order for the conditional insertion to
+ -- succeed.
+
+ -- We search the tree to find the nearest neighbor of Key, which is
+ -- either the smallest node greater than Key (Inserted is True), or the
+ -- largest node less or equivalent to Key (Inserted is False).
+ Y := 0;
X := Tree.Root;
Inserted := True;
while X /= 0 loop
X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X)));
end loop;
- -- If Inserted is True, then this means either that Tree is
- -- empty, or there was a least one node (strictly) greater than
- -- Key. Otherwise, it means that Key is equal to or greater than
- -- every node.
-
if Inserted then
+
+ -- Either Tree is empty, or Key is less than Y. If Y is the first
+ -- node in the tree, then there are no other nodes that we need to
+ -- search for, and we insert a new node into the tree.
+
if Y = Tree.First then
Insert_Post (Tree, Y, True, Node);
return;
end if;
+ -- Y is the next nearest-neighbor of Key. We know that Key is not
+ -- equivalent to Y (because Key is strictly less than Y), so we move
+ -- to the previous node, the nearest-neighbor just smaller or
+ -- equivalent to Key.
+
Node := Ops.Previous (Tree, Y);
else
+ -- Y is the previous nearest-neighbor of Key. We know that Key is not
+ -- less than Y, which means either that Key is equivalent to Y, or
+ -- greater than Y.
+
Node := Y;
end if;
- -- Here Node has a value that is less than or equal to Key. We
- -- now have to resolve whether Key is equal to or greater than
- -- Node, which determines whether the insertion succeeds.
+ -- Key is equivalent to or greater than Node. We must resolve which is
+ -- the case, to determine whether the conditional insertion succeeds.
if Is_Greater_Key_Node (Key, N (Node)) then
+
+ -- Key is strictly greater than Node, which means that Key is not
+ -- equivalent to Node. In this case, the insertion succeeds, and we
+ -- insert a new node into the tree.
+
Insert_Post (Tree, Y, Inserted, Node);
Inserted := True;
return;
end if;
+ -- Key is equivalent to Node. This is a conditional insertion, so we do
+ -- not insert a new node in this case. We return the existing node and
+ -- report that no insertion has occurred.
+
Inserted := False;
end Generic_Conditional_Insert;
procedure Establish_Task_Master (N : Node_Id) is
Call : Node_Id;
+
begin
if Restriction_Active (No_Task_Hierarchy) = False then
Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master);
- Prepend_To (Declarations (N), Call);
+
+ -- The block may have no declarations, and nevertheless be a task
+ -- master, if it contains a call that may return an object that
+ -- contains tasks.
+
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List (Call));
+ else
+ Prepend_To (Declarations (N), Call);
+ end if;
+
Analyze (Call);
end if;
end Establish_Task_Master;
procedure Do_Complete
(Project : Project_Id; Tree : Project_Tree_Ref)
is
+ J : Integer;
+
begin
if Mains.Number_Of_Mains (Tree) > 0
or else Mains.Count_Of_Mains_With_No_Tree > 0
-- files we will be adding extra files at the end, and there's
-- no need to process them in turn.
- for J in reverse Names.First .. Names.Last loop
+ J := Names.Last;
+ loop
declare
File : Main_Info := Names.Table (J);
Main_Id : File_Name_Type := File.File;
end if;
if Source /= No_Source then
+ if not Is_Allowed_Language
+ (Source.Language.Name)
+ then
+ -- Remove any main that is not in the list of
+ -- restricted languages.
- -- If we have found a multi-unit source file but
- -- did not specify an index initially, we'll need
- -- to compile all the units from the same source
- -- file.
+ Names.Table (J .. Names.Last - 1) :=
+ Names.Table (J + 1 .. Names.Last);
+ Names.Set_Last (Names.Last - 1);
- if Source.Index /= 0 and then File.Index = 0 then
- Add_Multi_Unit_Sources (File.Tree, Source);
- end if;
+ else
+ -- If we have found a multi-unit source file but
+ -- did not specify an index initially, we'll
+ -- need to compile all the units from the same
+ -- source file.
- -- Now update the original Main, otherwise it will
- -- be reported as not found.
+ if Source.Index /= 0 and then File.Index = 0 then
+ Add_Multi_Unit_Sources (File.Tree, Source);
+ end if;
- Debug_Output
- ("found main in project", Source.Project.Name);
- Names.Table (J).File := Source.File;
- Names.Table (J).Project := Source.Project;
+ -- Now update the original Main, otherwise it
+ -- will be reported as not found.
- if Names.Table (J).Tree = null then
- Names.Table (J).Tree := File.Tree;
+ Debug_Output
+ ("found main in project", Source.Project.Name);
+ Names.Table (J).File := Source.File;
+ Names.Table (J).Project := Source.Project;
- Builder_Data (File.Tree).Number_Of_Mains :=
- Builder_Data (File.Tree).Number_Of_Mains + 1;
- Mains.Count_Of_Mains_With_No_Tree :=
- Mains.Count_Of_Mains_With_No_Tree - 1;
- end if;
+ if Names.Table (J).Tree = null then
+ Names.Table (J).Tree := File.Tree;
- Names.Table (J).Source := Source;
- Names.Table (J).Index := Source.Index;
+ Builder_Data (File.Tree).Number_Of_Mains :=
+ Builder_Data (File.Tree).Number_Of_Mains
+ + 1;
+ Mains.Count_Of_Mains_With_No_Tree :=
+ Mains.Count_Of_Mains_With_No_Tree - 1;
+ end if;
+
+ Names.Table (J).Source := Source;
+ Names.Table (J).Index := Source.Index;
+ end if;
elsif File.Location /= No_Location then
end if;
end if;
end;
+
+ J := J - 1;
+ exit when J < Names.First;
end loop;
end if;
Source := Prj.Element (Iter);
exit when Source = No_Source;
- if Is_Compilable (Source)
+ if Is_Allowed_Language (Source.Language.Name)
+ and then Is_Compilable (Source)
and then
(All_Projects
- or else Is_Extending (Project, Source.Project))
+ or else Is_Extending (Project, Source.Project))
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then
procedure Report_No_Sources
(Project : Project_Id;
- Lang : Name_Id;
Lang_Name : String;
Data : Tree_Processing_Data;
Location : Source_Ptr;
Source_To_Replace : Source_Id := No_Source;
begin
- -- Nothing to do if the language is not one of the restricted ones
-
- if not Is_Allowed_Language (Lang_Id.Name) then
- Id := No_Source;
- return;
- end if;
-
-- Check if the same file name or unit is used in the prj tree
Add_Src := True;
if Source = No_Source then
Report_No_Sources
(Project.Project,
- Language.Name,
Get_Name_String (Language.Display_Name),
Data,
Project.Source_List_File_Location,
procedure Report_No_Sources
(Project : Project_Id;
- Lang : Name_Id;
Lang_Name : String;
Data : Tree_Processing_Data;
Location : Source_Ptr;
Continuation : Boolean := False)
is
begin
- if Is_Allowed_Language (Lang) then
- case Data.Flags.When_No_Sources is
+ case Data.Flags.When_No_Sources is
when Silent =>
null;
Error_Msg (Data.Flags, Msg, Location, Project);
end if;
end;
- end case;
- end if;
+ end case;
end Report_No_Sources;
----------------------
-- (this is an error that will be caught elsewhere);
Append_To (Private_Decls, PBody);
+
+ -- If the invariant appears on the full view of a type, the
+ -- analysis of the private part is complete, and we must
+ -- analyze the new body explicitly.
+
+ if In_Private_Part (Current_Scope) then
+ Analyze (PBody);
+ end if;
end if;
end if;
end Build_Invariant_Procedure;
Num_Out_Params := Num_Out_Params + 1;
end if;
+ -- Skip remaining processing if formal type was in error
+
+ if Etype (Formal) = Any_Type or else Error_Posted (Formal) then
+ goto Next_Parameter;
+ end if;
+
-- Force call by reference if aliased
if Is_Aliased (Formal) then
Set_Mechanism (Formal, By_Reference);
end if;
+ <<Next_Parameter>>
Next (Param_Spec);
end loop;
("full view of & does not have preelaborable initialization", E);
end if;
+ -- An invariant may appear on a full view of a type
+
+ if Is_Type (E)
+ and then Has_Private_Declaration (E)
+ and then Nkind (Parent (E)) = N_Full_Type_Declaration
+ and then Has_Aspects (Parent (E))
+ then
+ Build_Invariant_Procedure (E, N);
+ end if;
+
Next_Entity (E);
end loop;
-- check is not enforced when within an instance body, since the
-- RM requires such cases to be caught at run time.
- if Ekind (Target_Type) /= E_Anonymous_Access_Type then
+ -- If the operand is a rewriting of an allocator no check is needed
+ -- because there are no accessibility issues.
+
+ if Nkind (Original_Node (N)) = N_Allocator then
+ null;
+
+ elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) >
Deepest_Type_Access_Level (Target_Type)
then
projects / gcc.git / commitdiff