+2010-06-23 Javier Miranda <miranda@adacore.com>
+
+ * atree.ads (Set_Reporting_Proc): New subprogram.
+ * atree.adb: Remove dependency on packages Opt and SCIL_LL.
+ (Allocate_Initialize_Node, Replace, Rewrite): Replace direct calls
+ to routines of package Scil_ll by indirect call to the registered
+ subprogram.
+ (Set_Reporting_Proc): New subprogram. Used to register a subprogram
+ that is invoked when a node is allocated, replaced or rewritten.
+ * scil_ll.adb (Copy_SCIL_Node): New routine that takes care of copying
+ the SCIL node. Used as argument for Set_Reporting_Proc.
+ (Initialize): Register Copy_SCIL_Node as the reporting routine that
+ is invoked by atree.
+
+2010-06-23 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch3.ads: Minor reformatting.
+
+2010-06-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Package_Instantiation): In CodePeer mode,
+ always analyze the generic body and instance, because it may be needed
+ downstream.
+ (Mark_Context): Prepend the with clauses for needed generic units, so
+ they appear in a better order for CodePeer.
+ * sem_util.adb, sem_util.ads: Prototype code for AI05-0144.
+
+2010-06-23 Emmanuel Briot <briot@adacore.com>
+
+ * prj.ads, prj-nmsc.adb (Error_Or_Warning): New subprogram.
+
2010-06-23 Robert Dewar <dewar@adacore.com>
* g-pehage.adb, exp_ch13.adb: Minor reformatting.
with Debug; use Debug;
with Nlists; use Nlists;
-with Opt; use Opt;
with Output; use Output;
with Sinput; use Sinput;
-with SCIL_LL; use SCIL_LL;
with Tree_IO; use Tree_IO;
package body Atree is
+ Reporting_Proc : Report_Proc := null;
+ -- Record argument to last call to Set_Reporting_Proc
+
---------------
-- Debugging --
---------------
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
- -- Update the SCIL_Node field (if available)
+ -- Invoke the reporting procedure (if available)
- if Generate_SCIL then
- Set_SCIL_Node (New_Id, Get_SCIL_Node (Src));
+ if Reporting_Proc /= null then
+ Reporting_Proc.all (Target => New_Id, Source => Src);
end if;
return New_Id;
return Ekind_In (Ekind (E), V1, V2, V3, V4, V5, V6);
end Ekind_In;
+ ------------------------
+ -- Set_Reporting_Proc --
+ ------------------------
+
+ procedure Set_Reporting_Proc (P : Report_Proc) is
+ begin
+ pragma Assert (Reporting_Proc = null);
+ Reporting_Proc := P;
+ end Set_Reporting_Proc;
+
------------------
-- Error_Posted --
------------------
Orig_Nodes.Table (Old_Node) := Old_Node;
- -- Update the SCIL_Node field (if available)
+ -- Invoke the reporting procedure (if available)
- if Generate_SCIL then
- Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
+ if Reporting_Proc /= null then
+ Reporting_Proc.all (Target => Old_Node, Source => New_Node);
end if;
end Replace;
Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
- -- Update the SCIL_Node field (if available)
+ -- Invoke the reporting procedure (if available)
- if Generate_SCIL then
- Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
+ if Reporting_Proc /= null then
+ Reporting_Proc.all (Target => Old_Node, Source => New_Node);
end if;
end Rewrite;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 is used only by Sinfo.CN to change nodes into their
-- corresponding entities.
+ type Report_Proc is access procedure (Target : Node_Id; Source : Node_Id);
+
+ procedure Set_Reporting_Proc (P : Report_Proc);
+ -- Register a procedure that is invoked when a node is allocated, replaced
+ -- or rewritten.
+
type Traverse_Result is (Abandon, OK, OK_Orig, Skip);
-- This is the type of the result returned by the Process function passed
-- to Traverse_Func and Traverse_Proc. See below for details.
-- Debug print a value for a specific property. Does nothing when not in
-- debug mode
+ procedure Error_Or_Warning
+ (Flags : Processing_Flags;
+ Kind : Error_Warning;
+ Msg : String;
+ Location : Source_Ptr;
+ Project : Project_Id);
+ -- Emits either an error or warning message (or nothing), depending on Kind
+
+ ----------------------
+ -- Error_Or_Warning --
+ ----------------------
+
+ procedure Error_Or_Warning
+ (Flags : Processing_Flags;
+ Kind : Error_Warning;
+ Msg : String;
+ Location : Source_Ptr;
+ Project : Project_Id) is
+ begin
+ case Kind is
+ when Error => Error_Msg (Flags, Msg, Location, Project);
+ when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
+ when Silent => null;
+ end case;
+ end Error_Or_Warning;
+
------------------------------
-- Replace_Into_Name_Buffer --
------------------------------
begin
if Root_Dir'Length = 0 then
Err_Vars.Error_Msg_File_1 := Base_Dir;
- Error_Msg
- (Data.Flags,
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Missing_Source_Files,
"{ is not a valid directory.", Location, Project);
else
if not Dir_Exists then
Err_Vars.Error_Msg_File_1 := From;
- Error_Msg
- (Data.Flags,
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Missing_Source_Files,
"{ is not a valid directory", Location, Project);
else
Err_Vars.Error_Msg_File_1 :=
File_Name_Type (Object_Dir.Value);
-
- case Data.Flags.Require_Obj_Dirs is
- when Error =>
- Error_Msg
- (Data.Flags,
- "object directory { not found",
- Project.Location, Project);
- when Warning =>
- Error_Msg
- (Data.Flags,
- "?object directory { not found",
- Project.Location, Project);
- when Silent =>
- null;
- end case;
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Require_Obj_Dirs,
+ "object directory { not found", Project.Location, Project);
end if;
end if;
if not Found then
Error_Msg_Name_1 := Name_Id (Source.Display_File);
Error_Msg_Name_2 := Name_Id (Source.Unit.Name);
- Error_Msg
- (Data.Flags,
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Missing_Source_Files,
"source file %% for unit %% not found",
No_Location, Project.Project);
while NL /= No_Name_Location loop
if not NL.Found then
Err_Vars.Error_Msg_File_1 := NL.Name;
-
- case Data.Flags.Missing_Source_Files is
- when Error =>
- if First_Error then
- Error_Msg
- (Data.Flags,
- "source file { not found",
- NL.Location, Project.Project);
- First_Error := False;
-
- else
- Error_Msg
- (Data.Flags,
- "\source file { not found",
- NL.Location, Project.Project);
- end if;
-
- when Warning =>
- if First_Error then
- Error_Msg
- (Data.Flags,
- "?source file { not found",
- NL.Location, Project.Project);
- First_Error := False;
-
- else
- Error_Msg
- (Data.Flags,
- "?\source file { not found",
- NL.Location, Project.Project);
- end if;
-
- when Silent =>
- null;
- end case;
+ if First_Error then
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Missing_Source_Files,
+ "source file { not found",
+ NL.Location, Project.Project);
+ First_Error := False;
+ else
+ Error_Or_Warning
+ (Data.Flags, Data.Flags.Missing_Source_Files,
+ "\source file { not found",
+ NL.Location, Project.Project);
+ end if;
end if;
NL := Source_Names_Htable.Get_Next (Project.Source_Names);
--
-- Missing_Source_Files indicates whether it is an error or a warning that
-- a source file mentioned in the Source_Files attributes is not actually
- -- found in the source directories
+ -- found in the source directories. This also impacts errors for missing
+ -- source directories.
Gprbuild_Flags : constant Processing_Flags;
Gprclean_Flags : constant Processing_Flags;
package body SCIL_LL is
+ procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id);
+ -- Copy the SCIL field from Source to Target (it is used as the argument
+ -- for a call to Set_Reporting_Proc in package atree).
+
function SCIL_Nodes_Table_Size return Pos;
-- Used to initialize the table of SCIL nodes because we do not want
-- to consume memory for this table if it is not required.
-- This table records the value of attribute SCIL_Node of all the
-- tree nodes.
+ --------------------
+ -- Copy_SCIL_Node --
+ --------------------
+
+ procedure Copy_SCIL_Node (Target : Node_Id; Source : Node_Id) is
+ begin
+ Set_SCIL_Node (Target, Get_SCIL_Node (Source));
+ end Copy_SCIL_Node;
+
----------------
-- Initialize --
----------------
procedure Initialize is
begin
SCIL_Nodes.Init;
+ Set_Reporting_Proc (Copy_SCIL_Node'Access);
end Initialize;
-------------------
or else Enclosing_Body_Present
or else Present (Corresponding_Body (Gen_Decl)))
and then (Is_In_Main_Unit (N)
- or else Might_Inline_Subp)
+ or else Might_Inline_Subp
+ or else CodePeer_Mode)
and then not Is_Actual_Pack
and then not Inline_Now
and then (Operating_Mode = Generate_Code
Set_Implicit_With (Withn);
Set_Library_Unit (Withn, Cunit (CU));
Set_Withed_Body (Withn, Cunit (CU));
- Append (Withn, Context_Items (Cunit (Inst_CU)));
+ Prepend (Withn, Context_Items (Cunit (Inst_CU)));
end Add_Implicit_With;
begin
return;
end if;
- -- If G is itself declared within an instance, indicate that the generic
- -- body of that instance is also needed by C. This must be done
- -- recursively.
+ -- Nothing to do if G is local.
+
+ if Inst_CU = Gen_CU then
+ return;
+ end if;
+
+ -- If G is itself declared within an instance, indicate that the
+ -- generic body of that instance is also needed by C. This must be
+ -- done recursively.
Scop := Scope (Defining_Entity (Gen_Decl));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 Access_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Process an access type declaration
- procedure Build_Itype_Reference
- (Ityp : Entity_Id;
- Nod : Node_Id);
+ procedure Build_Itype_Reference (Ityp : Entity_Id; Nod : Node_Id);
-- Create a reference to an internal type, for use by Gigi. The back-end
- -- elaborates itypes on demand, i.e. when their first use is seen. This
- -- can lead to scope anomalies if the first use is within a scope that is
- -- nested within the scope that contains the point of definition of the
+ -- elaborates itypes on demand, i.e. when their first use is seen. This can
+ -- lead to scope anomalies if the first use is within a scope that is
+ -- nested within the scope that contains the point of definition of the
-- itype. The Itype_Reference node forces the elaboration of the itype
-- in the proper scope. The node is inserted after Nod, which is the
-- enclosing declaration that generated Ityp.
with Stand; use Stand;
with Style;
with Stringt; use Stringt;
+with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
subtype NCT_Header_Num is Int range 0 .. 511;
-- Defines range of headers in hash tables (512 headers)
+ -----------------------------------
+ -- Order dependence : AI05-0144 --
+ -----------------------------------
+
+ -- Each actual in a call is entered into the table below. A flag
+ -- indicates whether the corresponding formal is out or in out.
+ -- Each top-level call (procedure call, condition, assignment)
+ -- examines all the actuals for a possible order dependence.
+ -- The table is reset after each such check.
+
+ type Actual_Name is record
+ Act : Node_Id;
+ Is_Writable : Boolean;
+ end record;
+
+ package Actuals_In_Call is new Table.Table (
+ Table_Component_Type => Actual_Name,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Actuals");
+
+ procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
+ begin
+ if Is_Entity_Name (N)
+ or else Nkind_In (N,
+ N_Indexed_Component, N_Selected_Component, N_Slice)
+ or else (Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Access)
+
+ then
+ -- We are only interested in in out parameters of inner calls.
+
+ if not Writable
+ or else Nkind (Parent (N)) = N_Function_Call
+ or else Nkind (Parent (N)) in N_Op
+ then
+ Actuals_In_Call.Increment_Last;
+ Actuals_In_Call.Table (Actuals_In_Call.Last) := (N, Writable);
+ end if;
+ end if;
+ end Save_Actual;
+
+ procedure Check_Order_Dependence is
+ Act1, Act2 : Node_Id;
+ begin
+ for J in 0 .. Actuals_In_Call.Last loop
+
+ if Actuals_In_Call.Table (J).Is_Writable then
+ Act1 := Actuals_In_Call.Table (J).Act;
+
+ if Nkind (Act1) = N_Attribute_Reference then
+ Act1 := Prefix (Act1);
+ end if;
+
+ for K in 0 .. Actuals_In_Call.Last loop
+ if K /= J then
+ Act2 := Actuals_In_Call.Table (K).Act;
+ if Nkind (Act2) = N_Attribute_Reference then
+ Act2 := Prefix (Act2);
+ end if;
+
+ if Actuals_In_Call.Table (K).Is_Writable
+ and then K < J
+ then
+ -- already checked
+ null;
+
+ elsif Denotes_Same_Object (Act1, Act2)
+ and then False
+ then
+ Error_Msg_N ("?,mighty suspicious!!!", Act1);
+ end if;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Actuals_In_Call.Set_Last (0);
+ end Check_Order_Dependence;
+
-----------------------
-- Local Subprograms --
-----------------------
begin
if Is_Entity_Name (A1) then
- if Nkind_In (A2, N_Selected_Component, N_Indexed_Component) then
+ if Nkind_In (A2, N_Selected_Component, N_Indexed_Component)
+ and then not Is_Access_Type (Etype (A1))
+ then
return Denotes_Same_Object (A1, Prefix (A2))
or else Denotes_Same_Prefix (A1, Prefix (A2));
else
if Nkind (N) = N_Allocator then
if Is_Dynamic then
Set_Is_Dynamic_Coextension (N);
+
else
Set_Is_Static_Coextension (N);
end if;
-- is accessed inside a nested procedure, and set Has_Up_Level_Access flag
-- accordingly. This is currently only enabled for VM_Target /= No_VM.
+ procedure Check_Order_Dependence;
+ -- Examine the actuals in a top-level call to determine whether aliasing
+ -- between two actuals, one of which is writable, can make the call
+ -- order-dependent.
+
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
-- N is one of the statement forms that is a potentially blocking
-- operation. If it appears within a protected action, emit warning.
-- are only partially ordered, so Scope_Within_Or_Same (A,B) and
-- Scope_Within_Or_Same (B,A) can both be False for a given pair A,B.
+ procedure Save_Actual (N : Node_Id; Writable : Boolean := False);
+ -- Enter an actual in a call in a table global, for subsequent check
+ -- of possible order dependence in the presence of in out parameters
+ -- for functions in Ada 2012 (or access parameters in older versions
+ -- of the language).
+
function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean;
-- Like Scope_Within_Or_Same, except that this function returns
-- False in the case where Scope1 and Scope2 are the same scope.
OSDN Git Service
