Commit 8b034336 by Arnaud Charlet

[multiple changes]

2014-07-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Replace_Type_References_Generic): Use type entity
	as a parameter, rather than its Chars field, in order to locate
	freeze node of type. If the predicate or invariant has references
	to types other than the one to which the contract applies, these
	types must be frozen, and the corresponding predicate functions
	created, before that freeze node.

2014-07-18  Robert Dewar  <dewar@adacore.com>

	* freeze.adb, einfo.ads, einfo.adb: Minor code reorganization.
	* par_sco.adb: Minor reformatting.

2014-07-18  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch4.adb (Real_Range_Check): Turn off
	the Do_Range_Check flag on the conversion's current Expression
	argument rather than on the originally captured Operand node,
	as Expression may reflect a rewriting (as in conversions to a
	fixed-point type).

2014-07-18  Vincent Celier  <celier@adacore.com>

	* ali.adb (Scan_ALI): Set Sdep_Record.Unit_Name, when the unit
	is not a subunit.
	* ali.ads (Sdep_Record): New component Unit_Name.
	* lib-writ.adb (Write_ALI): Write the unit name in D lines.
	* makeutl.adb (Check_Source_Info_In_ALI): Return False if a
	dependent unit is in a project and the source file name is not
	one of its sources.

From-SVN: r212795
parent 47a98b97
2014-07-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Replace_Type_References_Generic): Use type entity
as a parameter, rather than its Chars field, in order to locate
freeze node of type. If the predicate or invariant has references
to types other than the one to which the contract applies, these
types must be frozen, and the corresponding predicate functions
created, before that freeze node.
2014-07-18 Robert Dewar <dewar@adacore.com>
* freeze.adb, einfo.ads, einfo.adb: Minor code reorganization.
* par_sco.adb: Minor reformatting.
2014-07-18 Gary Dismukes <dismukes@adacore.com>
* exp_ch4.adb (Real_Range_Check): Turn off
the Do_Range_Check flag on the conversion's current Expression
argument rather than on the originally captured Operand node,
as Expression may reflect a rewriting (as in conversions to a
fixed-point type).
2014-07-18 Vincent Celier <celier@adacore.com>
* ali.adb (Scan_ALI): Set Sdep_Record.Unit_Name, when the unit
is not a subunit.
* ali.ads (Sdep_Record): New component Unit_Name.
* lib-writ.adb (Write_ALI): Write the unit name in D lines.
* makeutl.adb (Check_Source_Info_In_ALI): Return False if a
dependent unit is in a project and the source file name is not
one of its sources.
2014-07-18 Bob Duff <duff@adacore.com> 2014-07-18 Bob Duff <duff@adacore.com>
* s-addima.ads: Minor: add comment. * s-addima.ads: Minor: add comment.
......
...@@ -2317,9 +2317,10 @@ package body ALI is ...@@ -2317,9 +2317,10 @@ package body ALI is
end if; end if;
end; end;
-- Acquire subunit and reference file name entries -- Acquire (sub)unit and reference file name entries
Sdep.Table (Sdep.Last).Subunit_Name := No_Name; Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
Sdep.Table (Sdep.Last).Unit_Name := No_Name;
Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Rfile :=
Sdep.Table (Sdep.Last).Sfile; Sdep.Table (Sdep.Last).Sfile;
Sdep.Table (Sdep.Last).Start_Line := 1; Sdep.Table (Sdep.Last).Start_Line := 1;
...@@ -2327,7 +2328,7 @@ package body ALI is ...@@ -2327,7 +2328,7 @@ package body ALI is
if not At_Eol then if not At_Eol then
Skip_Space; Skip_Space;
-- Here for subunit name -- Here for (sub)unit name
if Nextc not in '0' .. '9' then if Nextc not in '0' .. '9' then
Name_Len := 0; Name_Len := 0;
...@@ -2335,11 +2336,18 @@ package body ALI is ...@@ -2335,11 +2336,18 @@ package body ALI is
Add_Char_To_Name_Buffer (Getc); Add_Char_To_Name_Buffer (Getc);
end loop; end loop;
-- Set the subunit name. Note that we use Name_Find rather -- Set the (sub)unit name. Note that we use Name_Find rather
-- than Name_Enter here as the subunit name may already -- than Name_Enter here as the subunit name may already
-- have been put in the name table by the Project Manager. -- have been put in the name table by the Project Manager.
if Name_Len <= 2
or else Name_Buffer (Name_Len - 1) /= '%'
then
Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; Sdep.Table (Sdep.Last).Subunit_Name := Name_Find;
else
Name_Len := Name_Len - 2;
Sdep.Table (Sdep.Last).Unit_Name := Name_Find;
end if;
Skip_Space; Skip_Space;
end if; end if;
......
...@@ -767,6 +767,9 @@ package ALI is ...@@ -767,6 +767,9 @@ package ALI is
Subunit_Name : Name_Id; Subunit_Name : Name_Id;
-- Name_Id for subunit name if present, else No_Name -- Name_Id for subunit name if present, else No_Name
Unit_Name : Name_Id;
-- Name_Id for the unit name, if not a subunit. No_Name for a subunit.
Rfile : File_Name_Type; Rfile : File_Name_Type;
-- Reference file name. Same as Sfile unless a Source_Reference pragma -- Reference file name. Same as Sfile unless a Source_Reference pragma
-- was used, in which case it reflects the name used in the pragma. -- was used, in which case it reflects the name used in the pragma.
......
...@@ -7017,6 +7017,15 @@ package body Einfo is ...@@ -7017,6 +7017,15 @@ package body Einfo is
Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null; Ekind (Id) = E_Abstract_State and then Nkind (Parent (Id)) = N_Null;
end Is_Null_State; end Is_Null_State;
---------------------
-- Is_Packed_Array --
---------------------
function Is_Packed_Array (Id : E) return B is
begin
return Is_Array_Type (Id) and then Is_Packed (Id);
end Is_Packed_Array;
----------------------------------- -----------------------------------
-- Is_Package_Or_Generic_Package -- -- Is_Package_Or_Generic_Package --
----------------------------------- -----------------------------------
......
...@@ -2703,6 +2703,9 @@ package Einfo is ...@@ -2703,6 +2703,9 @@ package Einfo is
-- out that the component size is not suitable for bit packing, the -- out that the component size is not suitable for bit packing, the
-- Is_Packed flag gets turned off. -- Is_Packed flag gets turned off.
-- Is_Packed_Array (synth)
-- Applies to all entities, true if entity is for a packed array.
-- Is_Packed_Array_Type (Flag138) -- Is_Packed_Array_Type (Flag138)
-- Defined in all entities. This flag is set on the entity for the type -- Defined in all entities. This flag is set on the entity for the type
-- used to implement a packed array (either a modular type, or a subtype -- used to implement a packed array (either a modular type, or a subtype
...@@ -6874,6 +6877,7 @@ package Einfo is ...@@ -6874,6 +6877,7 @@ package Einfo is
function Is_Ghost_Subprogram (Id : E) return B; function Is_Ghost_Subprogram (Id : E) return B;
function Is_Null_State (Id : E) return B; function Is_Null_State (Id : E) return B;
function Is_Package_Or_Generic_Package (Id : E) return B; function Is_Package_Or_Generic_Package (Id : E) return B;
function Is_Packed_Array (Id : E) return B;
function Is_Prival (Id : E) return B; function Is_Prival (Id : E) return B;
function Is_Protected_Component (Id : E) return B; function Is_Protected_Component (Id : E) return B;
function Is_Protected_Interface (Id : E) return B; function Is_Protected_Interface (Id : E) return B;
...@@ -8634,6 +8638,7 @@ package Einfo is ...@@ -8634,6 +8638,7 @@ package Einfo is
pragma Inline (Base_Type); pragma Inline (Base_Type);
pragma Inline (Is_Base_Type); pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
pragma Inline (Is_Volatile); pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package); pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size); pragma Inline (Known_RM_Size);
......
...@@ -10191,7 +10191,13 @@ package body Exp_Ch4 is ...@@ -10191,7 +10191,13 @@ package body Exp_Ch4 is
and then S_Lov >= D_Lov and then S_Lov >= D_Lov
and then S_Hiv <= D_Hiv and then S_Hiv <= D_Hiv
then then
Set_Do_Range_Check (Operand, False); -- Unset the range check flag on the current value of
-- Expression (N), since the captured Operand may have
-- been rewritten (such as for the case of a conversion
-- to a fixed-point type).
Set_Do_Range_Check (Expression (N), False);
return; return;
end if; end if;
end; end;
......
...@@ -1095,20 +1095,6 @@ package body Freeze is ...@@ -1095,20 +1095,6 @@ package body Freeze is
Component_Aliased : Boolean; Component_Aliased : Boolean;
function Is_Packed_Array (T : Entity_Id) return Boolean;
-- True for a packed array type
---------------------
-- Is_Packed_Array --
---------------------
function Is_Packed_Array (T : Entity_Id) return Boolean is
begin
return Is_Array_Type (T) and then Is_Packed (T);
end Is_Packed_Array;
-- Start of processing for Check_Component_Storage_Order
begin begin
-- Record case -- Record case
...@@ -1121,10 +1107,9 @@ package body Freeze is ...@@ -1121,10 +1107,9 @@ package body Freeze is
Component_Aliased := False; Component_Aliased := False;
else else
-- If a component clause is present, check whether component -- If a component clause is present, check if the component starts
-- starts on a storage element boundary. Otherwise conservatively -- on a storage element boundary. Otherwise conservatively assume
-- assume it does so only in the case where the record is not -- it does so only in the case where the record is not packed.
-- packed.
if Present (Component_Clause (Comp)) then if Present (Component_Clause (Comp)) then
Comp_Byte_Aligned := Comp_Byte_Aligned :=
......
...@@ -1429,12 +1429,15 @@ package body Lib.Writ is ...@@ -1429,12 +1429,15 @@ package body Lib.Writ is
-- If subunit, add unit name, omitting the %b at the end -- If subunit, add unit name, omitting the %b at the end
if Present (Cunit (Unum)) if Present (Cunit (Unum)) then
and then Nkind (Unit (Cunit (Unum))) = N_Subunit
then
Get_Decoded_Name_String (Unit_Name (Unum)); Get_Decoded_Name_String (Unit_Name (Unum));
Write_Info_Char (' '); Write_Info_Char (' ');
if Nkind (Unit (Cunit (Unum))) = N_Subunit then
Write_Info_Str (Name_Buffer (1 .. Name_Len - 2)); Write_Info_Str (Name_Buffer (1 .. Name_Len - 2));
else
Write_Info_Str (Name_Buffer (1 .. Name_Len));
end if;
end if; end if;
-- If Source_Reference pragma used, output information -- If Source_Reference pragma used, output information
......
...@@ -320,6 +320,15 @@ package body Makeutl is ...@@ -320,6 +320,15 @@ package body Makeutl is
end; end;
end if; end if;
Unit_Name := SD.Unit_Name;
if Unit_Name /= No_Name
and then not Fname.Is_Internal_File_Name (SD.Sfile)
and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile)
then
return No_Name;
end if;
else else
-- For separates, the file is no longer associated with the -- For separates, the file is no longer associated with the
-- unit ("proc-sep.adb" is not associated with unit "proc.sep") -- unit ("proc-sep.adb" is not associated with unit "proc.sep")
......
...@@ -308,8 +308,8 @@ package body Par_SCO is ...@@ -308,8 +308,8 @@ package body Par_SCO is
function Check_Node (N : Node_Id) return Traverse_Result; function Check_Node (N : Node_Id) return Traverse_Result;
-- Determine if Nkind (N) indicates the presence of a decision (i.e. -- Determine if Nkind (N) indicates the presence of a decision (i.e.
-- N is a logical operator -- a decision in itelsf -- or an -- N is a logical operator, which is a decision in itself, or an
-- IF-expression -- whose Condition attribute is a decision). -- IF-expression whose Condition attribute is a decision).
---------------- ----------------
-- Check_Node -- -- Check_Node --
......
...@@ -33,6 +33,7 @@ with Errout; use Errout; ...@@ -33,6 +33,7 @@ with Errout; use Errout;
with Exp_Disp; use Exp_Disp; with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib; use Lib; with Lib; use Lib;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
with Namet; use Namet; with Namet; use Namet;
...@@ -155,14 +156,14 @@ package body Sem_Ch13 is ...@@ -155,14 +156,14 @@ package body Sem_Ch13 is
generic generic
with procedure Replace_Type_Reference (N : Node_Id); with procedure Replace_Type_Reference (N : Node_Id);
procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id);
-- This is used to scan an expression for a predicate or invariant aspect -- This is used to scan an expression for a predicate or invariant aspect
-- replacing occurrences of the name TName (the name of the subtype to -- replacing occurrences of the name of the subtype to which the aspect
-- which the aspect applies) with appropriate references to the parameter -- applies with appropriate references to the parameter of the predicate
-- of the predicate function or invariant procedure. The procedure passed -- function or invariant procedure. The procedure passed as a generic
-- as a generic parameter does the actual replacement of node N, which is -- parameter does the actual replacement of node N, which is either a
-- either a simple direct reference to TName, or a selected component that -- simple direct reference to T, or a selected component that represents
-- represents an appropriately qualified occurrence of TName. -- an appropriately qualified occurrence of T.
procedure Resolve_Iterable_Operation procedure Resolve_Iterable_Operation
(N : Node_Id; (N : Node_Id;
...@@ -7216,7 +7217,7 @@ package body Sem_Ch13 is ...@@ -7216,7 +7217,7 @@ package body Sem_Ch13 is
-- with references to the object, converted to type'Class in -- with references to the object, converted to type'Class in
-- the case of Invariant'Class aspects. -- the case of Invariant'Class aspects.
Replace_Type_References (Exp, Chars (T)); Replace_Type_References (Exp, T);
-- If this invariant comes from an aspect, find the aspect -- If this invariant comes from an aspect, find the aspect
-- specification, and replace the saved expression because -- specification, and replace the saved expression because
...@@ -7268,7 +7269,7 @@ package body Sem_Ch13 is ...@@ -7268,7 +7269,7 @@ package body Sem_Ch13 is
Inv : constant Node_Id := Inv : constant Node_Id :=
Expression (Corresponding_Aspect (Ritem)); Expression (Corresponding_Aspect (Ritem));
begin begin
Replace_Type_References (Inv, Chars (T)); Replace_Type_References (Inv, T);
Preanalyze_Assert_Expression (Inv, Standard_Boolean); Preanalyze_Assert_Expression (Inv, Standard_Boolean);
end; end;
end if; end if;
...@@ -7656,7 +7657,7 @@ package body Sem_Ch13 is ...@@ -7656,7 +7657,7 @@ package body Sem_Ch13 is
-- We need to replace any occurrences of the name of the -- We need to replace any occurrences of the name of the
-- type with references to the object. -- type with references to the object.
Replace_Type_References (Arg2, Chars (Typ)); Replace_Type_References (Arg2, Typ);
-- If this predicate comes from an aspect, find the aspect -- If this predicate comes from an aspect, find the aspect
-- specification, and replace the saved expression because -- specification, and replace the saved expression because
...@@ -10303,7 +10304,7 @@ package body Sem_Ch13 is ...@@ -10303,7 +10304,7 @@ package body Sem_Ch13 is
Replace (N, Make_Null_Statement (Sloc (N))); Replace (N, Make_Null_Statement (Sloc (N)));
-- The null statement must be marked as not coming from source. This is -- The null statement must be marked as not coming from source. This is
-- so that ASIS ignores if, and also the back end does not expect bogus -- so that ASIS ignores it, and also the back end does not expect bogus
-- "from source" null statements in weird places (e.g. in declarative -- "from source" null statements in weird places (e.g. in declarative
-- regions where such null statements are not allowed). -- regions where such null statements are not allowed).
...@@ -10837,7 +10838,8 @@ package body Sem_Ch13 is ...@@ -10837,7 +10838,8 @@ package body Sem_Ch13 is
-- Replace_Type_References_Generic -- -- Replace_Type_References_Generic --
------------------------------------- -------------------------------------
procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is
TName : constant Name_Id := Chars (T);
function Replace_Node (N : Node_Id) return Traverse_Result; function Replace_Node (N : Node_Id) return Traverse_Result;
-- Processes a single node in the traversal procedure below, checking -- Processes a single node in the traversal procedure below, checking
...@@ -10859,9 +10861,18 @@ package body Sem_Ch13 is ...@@ -10859,9 +10861,18 @@ package body Sem_Ch13 is
if Nkind (N) = N_Identifier then if Nkind (N) = N_Identifier then
-- If not the type name, all done with this node -- If not the type name, check whether it is a reference to
-- some other type, which must be frozen before the predicate
-- function is analyzed, i.e. before the freeze node of the
-- type to which the predicate applies.
if Chars (N) /= TName then if Chars (N) /= TName then
if Present (Current_Entity (N))
and then Is_Type (Current_Entity (N))
then
Freeze_Before (Freeze_Node (T), Current_Entity (N));
end if;
return Skip; return Skip;
-- Otherwise do the replacement and we are done with this node -- Otherwise do the replacement and we are done with this node
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment