mirror of git://gcc.gnu.org/git/gcc.git
[multiple changes]
2009-07-28 Emmanuel Briot <briot@adacore.com> * prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the importing project does not end up in the list, in the case of extending projects. * make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to makeutl.ads, for better sharing with gprbuild. 2009-07-28 Arnaud Charlet <charlet@adacore.com> * gnat_ugn.texi: Fix typo. 2009-07-28 Ed Schonberg <schonberg@adacore.com> * sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a derivation that renames some discriminants and constrain others. * exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the prefix is a derived untagged type, convert to the root type to conform to the signature of the protected operations. 2009-07-28 Robert Dewar <dewar@adacore.com> * sinfo.ads: Update comments. * exp_attr.adb: Minor reformatting From-SVN: r150152
This commit is contained in:
parent
55603e5ee2
commit
f7e71125e2
|
@ -1,3 +1,28 @@
|
||||||
|
2009-07-28 Emmanuel Briot <briot@adacore.com>
|
||||||
|
|
||||||
|
* prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the
|
||||||
|
importing project does not end up in the list, in the case of extending
|
||||||
|
projects.
|
||||||
|
* make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to
|
||||||
|
makeutl.ads, for better sharing with gprbuild.
|
||||||
|
|
||||||
|
2009-07-28 Arnaud Charlet <charlet@adacore.com>
|
||||||
|
|
||||||
|
* gnat_ugn.texi: Fix typo.
|
||||||
|
|
||||||
|
2009-07-28 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
|
* sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a
|
||||||
|
derivation that renames some discriminants and constrain others.
|
||||||
|
* exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the
|
||||||
|
prefix is a derived untagged type, convert to the root type to conform
|
||||||
|
to the signature of the protected operations.
|
||||||
|
|
||||||
|
2009-07-28 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
|
* sinfo.ads: Update comments.
|
||||||
|
* exp_attr.adb: Minor reformatting
|
||||||
|
|
||||||
2009-07-28 Ed Schonberg <schonberg@adacore.com>
|
2009-07-28 Ed Schonberg <schonberg@adacore.com>
|
||||||
|
|
||||||
* sem_aggr.adb (Get_Value): A named association in a record aggregate
|
* sem_aggr.adb (Get_Value): A named association in a record aggregate
|
||||||
|
|
|
@ -358,7 +358,7 @@ package body Exp_Attr is
|
||||||
|
|
||||||
Sub_Ref :=
|
Sub_Ref :=
|
||||||
Make_Attribute_Reference (Loc,
|
Make_Attribute_Reference (Loc,
|
||||||
Prefix => Sub,
|
Prefix => Sub,
|
||||||
Attribute_Name => Name_Access);
|
Attribute_Name => Name_Access);
|
||||||
|
|
||||||
-- We set the type of the access reference to the already generated
|
-- We set the type of the access reference to the already generated
|
||||||
|
@ -370,17 +370,13 @@ package body Exp_Attr is
|
||||||
|
|
||||||
Agg :=
|
Agg :=
|
||||||
Make_Aggregate (Loc,
|
Make_Aggregate (Loc,
|
||||||
Expressions =>
|
Expressions => New_List (Obj_Ref, Sub_Ref));
|
||||||
New_List (
|
|
||||||
Obj_Ref, Sub_Ref));
|
|
||||||
|
|
||||||
Rewrite (N, Agg);
|
Rewrite (N, Agg);
|
||||||
|
|
||||||
Analyze_And_Resolve (N, E_T);
|
Analyze_And_Resolve (N, E_T);
|
||||||
|
|
||||||
-- For subsequent analysis, the node must retain its type.
|
-- For subsequent analysis, the node must retain its type. The backend
|
||||||
-- The backend will replace it with the equivalent type where
|
-- will replace it with the equivalent type where needed.
|
||||||
-- needed.
|
|
||||||
|
|
||||||
Set_Etype (N, Typ);
|
Set_Etype (N, Typ);
|
||||||
end Expand_Access_To_Protected_Op;
|
end Expand_Access_To_Protected_Op;
|
||||||
|
|
|
@ -3193,6 +3193,18 @@ package body Exp_Ch9 is
|
||||||
Params := New_List;
|
Params := New_List;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- If the type is an untagged derived type, convert to the root type,
|
||||||
|
-- which is the one on which the operations are defined.
|
||||||
|
|
||||||
|
if Nkind (Rec) = N_Unchecked_Type_Conversion
|
||||||
|
and then not Is_Tagged_Type (Etype (Rec))
|
||||||
|
and then Is_Derived_Type (Etype (Rec))
|
||||||
|
then
|
||||||
|
Set_Etype (Rec, Root_Type (Etype (Rec)));
|
||||||
|
Set_Subtype_Mark (Rec,
|
||||||
|
New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
|
||||||
|
end if;
|
||||||
|
|
||||||
Prepend (Rec, Params);
|
Prepend (Rec, Params);
|
||||||
|
|
||||||
if Ekind (Sub) = E_Procedure then
|
if Ekind (Sub) = E_Procedure then
|
||||||
|
@ -4358,8 +4370,8 @@ package body Exp_Ch9 is
|
||||||
return N;
|
return N;
|
||||||
else
|
else
|
||||||
return
|
return
|
||||||
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
|
Unchecked_Convert_To
|
||||||
New_Copy_Tree (N));
|
(Corresponding_Record_Type (Typ), New_Copy_Tree (N));
|
||||||
end if;
|
end if;
|
||||||
end Convert_Concurrent;
|
end Convert_Concurrent;
|
||||||
|
|
||||||
|
|
|
@ -557,25 +557,6 @@ package body Make is
|
||||||
procedure List_Bad_Compilations;
|
procedure List_Bad_Compilations;
|
||||||
-- Prints out the list of all files for which the compilation failed
|
-- Prints out the list of all files for which the compilation failed
|
||||||
|
|
||||||
procedure Verbose_Msg
|
|
||||||
(N1 : Name_Id;
|
|
||||||
S1 : String;
|
|
||||||
N2 : Name_Id := No_Name;
|
|
||||||
S2 : String := "";
|
|
||||||
Prefix : String := " -> ";
|
|
||||||
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
|
|
||||||
procedure Verbose_Msg
|
|
||||||
(N1 : File_Name_Type;
|
|
||||||
S1 : String;
|
|
||||||
N2 : File_Name_Type := No_File;
|
|
||||||
S2 : String := "";
|
|
||||||
Prefix : String := " -> ";
|
|
||||||
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
|
|
||||||
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is
|
|
||||||
-- at least equal to Minimum_Verbosity, then print Prefix to standard
|
|
||||||
-- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
|
|
||||||
-- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
|
|
||||||
|
|
||||||
Usage_Needed : Boolean := True;
|
Usage_Needed : Boolean := True;
|
||||||
-- Flag used to make sure Makeusg is call at most once
|
-- Flag used to make sure Makeusg is call at most once
|
||||||
|
|
||||||
|
@ -1434,10 +1415,6 @@ package body Make is
|
||||||
O_File : out File_Name_Type;
|
O_File : out File_Name_Type;
|
||||||
O_Stamp : out Time_Stamp_Type)
|
O_Stamp : out Time_Stamp_Type)
|
||||||
is
|
is
|
||||||
function File_Not_A_Source_Of
|
|
||||||
(Uname : Name_Id;
|
|
||||||
Sfile : File_Name_Type) return Boolean;
|
|
||||||
|
|
||||||
function First_New_Spec (A : ALI_Id) return File_Name_Type;
|
function First_New_Spec (A : ALI_Id) return File_Name_Type;
|
||||||
-- Looks in the with table entries of A and returns the spec file name
|
-- Looks in the with table entries of A and returns the spec file name
|
||||||
-- of the first withed unit (subprogram) for which no spec existed when
|
-- of the first withed unit (subprogram) for which no spec existed when
|
||||||
|
@ -1452,34 +1429,6 @@ package body Make is
|
||||||
-- services, but this causes the whole compiler to be dragged along
|
-- services, but this causes the whole compiler to be dragged along
|
||||||
-- for gnatbind and gnatmake.
|
-- for gnatbind and gnatmake.
|
||||||
|
|
||||||
--------------------------
|
|
||||||
-- File_Not_A_Source_Of --
|
|
||||||
--------------------------
|
|
||||||
|
|
||||||
function File_Not_A_Source_Of
|
|
||||||
(Uname : Name_Id;
|
|
||||||
Sfile : File_Name_Type) return Boolean
|
|
||||||
is
|
|
||||||
UID : Prj.Unit_Index;
|
|
||||||
|
|
||||||
begin
|
|
||||||
UID := Units_Htable.Get (Project_Tree.Units_HT, Uname);
|
|
||||||
|
|
||||||
if UID /= Prj.No_Unit_Index then
|
|
||||||
if (UID.File_Names (Impl) = null
|
|
||||||
or else UID.File_Names (Impl).File /= Sfile)
|
|
||||||
and then
|
|
||||||
(UID.File_Names (Spec) = null
|
|
||||||
or else UID.File_Names (Spec).File /= Sfile)
|
|
||||||
then
|
|
||||||
Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
|
|
||||||
return True;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
return False;
|
|
||||||
end File_Not_A_Source_Of;
|
|
||||||
|
|
||||||
--------------------
|
--------------------
|
||||||
-- First_New_Spec --
|
-- First_New_Spec --
|
||||||
--------------------
|
--------------------
|
||||||
|
@ -8240,52 +8189,6 @@ package body Make is
|
||||||
end if;
|
end if;
|
||||||
end Usage;
|
end Usage;
|
||||||
|
|
||||||
-----------------
|
|
||||||
-- Verbose_Msg --
|
|
||||||
-----------------
|
|
||||||
|
|
||||||
procedure Verbose_Msg
|
|
||||||
(N1 : Name_Id;
|
|
||||||
S1 : String;
|
|
||||||
N2 : Name_Id := No_Name;
|
|
||||||
S2 : String := "";
|
|
||||||
Prefix : String := " -> ";
|
|
||||||
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
|
|
||||||
is
|
|
||||||
begin
|
|
||||||
if (not Verbose_Mode) or else (Minimum_Verbosity > Verbosity_Level) then
|
|
||||||
return;
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Write_Str (Prefix);
|
|
||||||
Write_Str ("""");
|
|
||||||
Write_Name (N1);
|
|
||||||
Write_Str (""" ");
|
|
||||||
Write_Str (S1);
|
|
||||||
|
|
||||||
if N2 /= No_Name then
|
|
||||||
Write_Str (" """);
|
|
||||||
Write_Name (N2);
|
|
||||||
Write_Str (""" ");
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Write_Str (S2);
|
|
||||||
Write_Eol;
|
|
||||||
end Verbose_Msg;
|
|
||||||
|
|
||||||
procedure Verbose_Msg
|
|
||||||
(N1 : File_Name_Type;
|
|
||||||
S1 : String;
|
|
||||||
N2 : File_Name_Type := No_File;
|
|
||||||
S2 : String := "";
|
|
||||||
Prefix : String := " -> ";
|
|
||||||
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
|
|
||||||
is
|
|
||||||
begin
|
|
||||||
Verbose_Msg
|
|
||||||
(Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
|
|
||||||
end Verbose_Msg;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
-- Make sure that in case of failure, the temp files will be deleted
|
-- Make sure that in case of failure, the temp files will be deleted
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,7 @@
|
||||||
with Debug;
|
with Debug;
|
||||||
with Osint; use Osint;
|
with Osint; use Osint;
|
||||||
with Output; use Output;
|
with Output; use Output;
|
||||||
|
with Opt; use Opt;
|
||||||
with Prj.Ext;
|
with Prj.Ext;
|
||||||
with Prj.Util;
|
with Prj.Util;
|
||||||
with Snames; use Snames;
|
with Snames; use Snames;
|
||||||
|
@ -264,6 +265,47 @@ package body Makeutl is
|
||||||
end;
|
end;
|
||||||
end Executable_Prefix_Path;
|
end Executable_Prefix_Path;
|
||||||
|
|
||||||
|
--------------------------
|
||||||
|
-- File_Not_A_Source_Of --
|
||||||
|
--------------------------
|
||||||
|
|
||||||
|
function File_Not_A_Source_Of
|
||||||
|
(Uname : Name_Id;
|
||||||
|
Sfile : File_Name_Type) return Boolean
|
||||||
|
is
|
||||||
|
Unit : constant Unit_Index :=
|
||||||
|
Units_Htable.Get (Project_Tree.Units_HT, Uname);
|
||||||
|
|
||||||
|
At_Least_One_File : Boolean := False;
|
||||||
|
|
||||||
|
begin
|
||||||
|
if Unit /= No_Unit_Index then
|
||||||
|
for F in Unit.File_Names'Range loop
|
||||||
|
if Unit.File_Names (F) /= null then
|
||||||
|
At_Least_One_File := True;
|
||||||
|
if Unit.File_Names (F).File = Sfile then
|
||||||
|
return False;
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
if not At_Least_One_File then
|
||||||
|
|
||||||
|
-- The unit was probably created initially for a separate unit
|
||||||
|
-- (which are initially created as IMPL when both suffixes are the
|
||||||
|
-- same). Later on, Override_Kind changed the type of the file,
|
||||||
|
-- and the unit is no longer valid in fact.
|
||||||
|
|
||||||
|
return False;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
|
||||||
|
return True;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
return False;
|
||||||
|
end File_Not_A_Source_Of;
|
||||||
|
|
||||||
----------
|
----------
|
||||||
-- Hash --
|
-- Hash --
|
||||||
----------
|
----------
|
||||||
|
@ -749,4 +791,52 @@ package body Makeutl is
|
||||||
return Result;
|
return Result;
|
||||||
end Unit_Index_Of;
|
end Unit_Index_Of;
|
||||||
|
|
||||||
|
-----------------
|
||||||
|
-- Verbose_Msg --
|
||||||
|
-----------------
|
||||||
|
|
||||||
|
procedure Verbose_Msg
|
||||||
|
(N1 : Name_Id;
|
||||||
|
S1 : String;
|
||||||
|
N2 : Name_Id := No_Name;
|
||||||
|
S2 : String := "";
|
||||||
|
Prefix : String := " -> ";
|
||||||
|
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
|
||||||
|
is
|
||||||
|
begin
|
||||||
|
if not Opt.Verbose_Mode
|
||||||
|
or else Minimum_Verbosity > Opt.Verbosity_Level
|
||||||
|
then
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Write_Str (Prefix);
|
||||||
|
Write_Str ("""");
|
||||||
|
Write_Name (N1);
|
||||||
|
Write_Str (""" ");
|
||||||
|
Write_Str (S1);
|
||||||
|
|
||||||
|
if N2 /= No_Name then
|
||||||
|
Write_Str (" """);
|
||||||
|
Write_Name (N2);
|
||||||
|
Write_Str (""" ");
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Write_Str (S2);
|
||||||
|
Write_Eol;
|
||||||
|
end Verbose_Msg;
|
||||||
|
|
||||||
|
procedure Verbose_Msg
|
||||||
|
(N1 : File_Name_Type;
|
||||||
|
S1 : String;
|
||||||
|
N2 : File_Name_Type := No_File;
|
||||||
|
S2 : String := "";
|
||||||
|
Prefix : String := " -> ";
|
||||||
|
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
|
||||||
|
is
|
||||||
|
begin
|
||||||
|
Verbose_Msg
|
||||||
|
(Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
|
||||||
|
end Verbose_Msg;
|
||||||
|
|
||||||
end Makeutl;
|
end Makeutl;
|
||||||
|
|
|
@ -24,6 +24,7 @@
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
|
|
||||||
with Namet; use Namet;
|
with Namet; use Namet;
|
||||||
|
with Opt;
|
||||||
with Osint;
|
with Osint;
|
||||||
with Prj; use Prj;
|
with Prj; use Prj;
|
||||||
with Types; use Types;
|
with Types; use Types;
|
||||||
|
@ -69,6 +70,13 @@ package Makeutl is
|
||||||
procedure Inform (N : File_Name_Type; Msg : String);
|
procedure Inform (N : File_Name_Type; Msg : String);
|
||||||
-- Prints out the program name followed by a colon, N and S
|
-- Prints out the program name followed by a colon, N and S
|
||||||
|
|
||||||
|
function File_Not_A_Source_Of
|
||||||
|
(Uname : Name_Id;
|
||||||
|
Sfile : File_Name_Type) return Boolean;
|
||||||
|
-- Check that file name Sfile is one of the source of unit Uname.
|
||||||
|
-- Returns True if the unit is in one of the project file, but the file
|
||||||
|
-- name is not one of its source. Returns False otherwise.
|
||||||
|
|
||||||
function Is_External_Assignment (Argv : String) return Boolean;
|
function Is_External_Assignment (Argv : String) return Boolean;
|
||||||
-- Verify that an external assignment switch is syntactically correct
|
-- Verify that an external assignment switch is syntactically correct
|
||||||
--
|
--
|
||||||
|
@ -82,6 +90,25 @@ package Makeutl is
|
||||||
-- been entered by a call to Prj.Ext.Add, so that in a project
|
-- been entered by a call to Prj.Ext.Add, so that in a project
|
||||||
-- file, External ("name") will return "value".
|
-- file, External ("name") will return "value".
|
||||||
|
|
||||||
|
procedure Verbose_Msg
|
||||||
|
(N1 : Name_Id;
|
||||||
|
S1 : String;
|
||||||
|
N2 : Name_Id := No_Name;
|
||||||
|
S2 : String := "";
|
||||||
|
Prefix : String := " -> ";
|
||||||
|
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
|
||||||
|
procedure Verbose_Msg
|
||||||
|
(N1 : File_Name_Type;
|
||||||
|
S1 : String;
|
||||||
|
N2 : File_Name_Type := No_File;
|
||||||
|
S2 : String := "";
|
||||||
|
Prefix : String := " -> ";
|
||||||
|
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
|
||||||
|
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is
|
||||||
|
-- at least equal to Minimum_Verbosity, then print Prefix to standard
|
||||||
|
-- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
|
||||||
|
-- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
|
||||||
|
|
||||||
function Linker_Options_Switches
|
function Linker_Options_Switches
|
||||||
(Project : Project_Id;
|
(Project : Project_Id;
|
||||||
In_Tree : Project_Tree_Ref) return String_List;
|
In_Tree : Project_Tree_Ref) return String_List;
|
||||||
|
|
|
@ -1069,8 +1069,8 @@ package body Prj is
|
||||||
begin
|
begin
|
||||||
-- A project is not importing itself
|
-- A project is not importing itself
|
||||||
|
|
||||||
if Project /= Prj then
|
Prj2 := Ultimate_Extending_Project_Of (Prj);
|
||||||
Prj2 := Ultimate_Extending_Project_Of (Prj);
|
if Project /= Prj2 then
|
||||||
|
|
||||||
-- Check that the project is not already in the list. We know the
|
-- Check that the project is not already in the list. We know the
|
||||||
-- one passed to Recursive_Add have never been visited before, but
|
-- one passed to Recursive_Add have never been visited before, but
|
||||||
|
|
|
@ -1061,7 +1061,8 @@ package Prj is
|
||||||
-- The list of all directly imported projects, if any
|
-- The list of all directly imported projects, if any
|
||||||
|
|
||||||
All_Imported_Projects : Project_List;
|
All_Imported_Projects : Project_List;
|
||||||
-- The list of all projects imported directly or indirectly, if any
|
-- The list of all projects imported directly or indirectly, if any.
|
||||||
|
-- This does not include the project itself.
|
||||||
|
|
||||||
-----------------
|
-----------------
|
||||||
-- Directories --
|
-- Directories --
|
||||||
|
|
|
@ -4826,17 +4826,72 @@ package body Sem_Ch3 is
|
||||||
Parent_Type : Entity_Id;
|
Parent_Type : Entity_Id;
|
||||||
Derived_Type : Entity_Id)
|
Derived_Type : Entity_Id)
|
||||||
is
|
is
|
||||||
D_Constraint : Node_Id;
|
Loc : constant Source_Ptr := Sloc (N);
|
||||||
Disc_Spec : Node_Id;
|
|
||||||
Old_Disc : Entity_Id;
|
|
||||||
New_Disc : Entity_Id;
|
|
||||||
|
|
||||||
Constraint_Present : constant Boolean :=
|
Corr_Record : constant Entity_Id
|
||||||
Nkind (Subtype_Indication (Type_Definition (N)))
|
:= Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
|
||||||
= N_Subtype_Indication;
|
Corr_Decl : Node_Id;
|
||||||
|
Corr_Decl_Needed : Boolean;
|
||||||
|
-- If the derived type has fewer discriminants than its parent,
|
||||||
|
-- the corresponding record is also a derived type, in order to
|
||||||
|
-- account for the bound discriminants. We create a full type
|
||||||
|
-- declaration for it in this case.
|
||||||
|
|
||||||
|
Constraint_Present : constant Boolean
|
||||||
|
:= Nkind (Subtype_Indication (Type_Definition (N)))
|
||||||
|
= N_Subtype_Indication;
|
||||||
|
|
||||||
|
D_Constraint : Node_Id;
|
||||||
|
New_Constraint : Elist_Id;
|
||||||
|
Old_Disc : Entity_Id;
|
||||||
|
New_Disc : Entity_Id;
|
||||||
|
New_N : Node_Id;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Set_Stored_Constraint (Derived_Type, No_Elist);
|
Set_Stored_Constraint (Derived_Type, No_Elist);
|
||||||
|
Corr_Decl_Needed := False;
|
||||||
|
Old_Disc := Empty;
|
||||||
|
|
||||||
|
if Present (Discriminant_Specifications (N))
|
||||||
|
and then Constraint_Present
|
||||||
|
then
|
||||||
|
Old_Disc := First_Discriminant (Parent_Type);
|
||||||
|
New_Disc := First (Discriminant_Specifications (N));
|
||||||
|
while Present (New_Disc) and then Present (Old_Disc) loop
|
||||||
|
Next_Discriminant (Old_Disc);
|
||||||
|
Next (New_Disc);
|
||||||
|
end loop;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
if Present (Old_Disc) then
|
||||||
|
|
||||||
|
-- The new type has fewer discriminants, so we need to create a new
|
||||||
|
-- corresponding record, which is derived from the corresponding
|
||||||
|
-- record of the parent, and has a stored constraint that
|
||||||
|
-- captures the values of the discriminant constraints.
|
||||||
|
-- The type declaration for the derived corresponding record has
|
||||||
|
-- the same discriminant part and constraints as the current
|
||||||
|
-- declaration. Copy the unanalyzed tree to build declaration.
|
||||||
|
|
||||||
|
Corr_Decl_Needed := True;
|
||||||
|
New_N := Copy_Separate_Tree (N);
|
||||||
|
|
||||||
|
Corr_Decl :=
|
||||||
|
Make_Full_Type_Declaration (Loc,
|
||||||
|
Defining_Identifier => Corr_Record,
|
||||||
|
Discriminant_Specifications =>
|
||||||
|
Discriminant_Specifications (New_N),
|
||||||
|
Type_Definition =>
|
||||||
|
Make_Derived_Type_Definition (Loc,
|
||||||
|
Subtype_Indication =>
|
||||||
|
Make_Subtype_Indication (Loc,
|
||||||
|
Subtype_Mark =>
|
||||||
|
New_Occurrence_Of
|
||||||
|
(Corresponding_Record_Type (Parent_Type), Loc),
|
||||||
|
Constraint =>
|
||||||
|
Constraint
|
||||||
|
(Subtype_Indication (Type_Definition (New_N))))));
|
||||||
|
end if;
|
||||||
|
|
||||||
-- Copy Storage_Size and Relative_Deadline variables if task case
|
-- Copy Storage_Size and Relative_Deadline variables if task case
|
||||||
|
|
||||||
|
@ -4850,6 +4905,16 @@ package body Sem_Ch3 is
|
||||||
if Present (Discriminant_Specifications (N)) then
|
if Present (Discriminant_Specifications (N)) then
|
||||||
Push_Scope (Derived_Type);
|
Push_Scope (Derived_Type);
|
||||||
Check_Or_Process_Discriminants (N, Derived_Type);
|
Check_Or_Process_Discriminants (N, Derived_Type);
|
||||||
|
|
||||||
|
if Constraint_Present then
|
||||||
|
New_Constraint :=
|
||||||
|
Expand_To_Stored_Constraint
|
||||||
|
(Parent_Type,
|
||||||
|
Build_Discriminant_Constraints
|
||||||
|
(Parent_Type,
|
||||||
|
Subtype_Indication (Type_Definition (N)), True));
|
||||||
|
end if;
|
||||||
|
|
||||||
End_Scope;
|
End_Scope;
|
||||||
|
|
||||||
elsif Constraint_Present then
|
elsif Constraint_Present then
|
||||||
|
@ -4880,9 +4945,9 @@ package body Sem_Ch3 is
|
||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- All attributes are inherited from parent. In particular,
|
-- By default, operations and private data are inherited from parent.
|
||||||
-- entries and the corresponding record type are the same.
|
-- However, in the presence of bound discriminants, a new corresponding
|
||||||
-- Discriminants may be renamed, and must be treated separately.
|
-- record will be created, see below.
|
||||||
|
|
||||||
Set_Has_Discriminants
|
Set_Has_Discriminants
|
||||||
(Derived_Type, Has_Discriminants (Parent_Type));
|
(Derived_Type, Has_Discriminants (Parent_Type));
|
||||||
|
@ -4910,44 +4975,99 @@ package body Sem_Ch3 is
|
||||||
(Constraints
|
(Constraints
|
||||||
(Constraint (Subtype_Indication (Type_Definition (N)))));
|
(Constraint (Subtype_Indication (Type_Definition (N)))));
|
||||||
|
|
||||||
Old_Disc := First_Discriminant (Parent_Type);
|
Old_Disc := First_Discriminant (Parent_Type);
|
||||||
New_Disc := First_Discriminant (Derived_Type);
|
|
||||||
Disc_Spec := First (Discriminant_Specifications (N));
|
|
||||||
while Present (Old_Disc) and then Present (Disc_Spec) loop
|
|
||||||
if Nkind (Discriminant_Type (Disc_Spec)) /=
|
|
||||||
N_Access_Definition
|
|
||||||
then
|
|
||||||
Analyze (Discriminant_Type (Disc_Spec));
|
|
||||||
|
|
||||||
if not Subtypes_Statically_Compatible (
|
while Present (D_Constraint) loop
|
||||||
Etype (Discriminant_Type (Disc_Spec)),
|
if Nkind (D_Constraint) /= N_Discriminant_Association then
|
||||||
Etype (Old_Disc))
|
|
||||||
then
|
-- Positional constraint. If it is a reference to a
|
||||||
Error_Msg_N
|
-- new discriminant, it constrains the corresponding
|
||||||
("not statically compatible with parent discriminant",
|
-- old one.
|
||||||
Discriminant_Type (Disc_Spec));
|
|
||||||
|
if Nkind (D_Constraint) = N_Identifier then
|
||||||
|
New_Disc := First_Discriminant (Derived_Type);
|
||||||
|
while Present (New_Disc) loop
|
||||||
|
exit when
|
||||||
|
Chars (New_Disc) = Chars (D_Constraint);
|
||||||
|
Next_Discriminant (New_Disc);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
if Present (New_Disc) then
|
||||||
|
Set_Corresponding_Discriminant (New_Disc, Old_Disc);
|
||||||
|
end if;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next_Discriminant (Old_Disc);
|
||||||
|
|
||||||
|
-- if this is a named constraint, search by name for the
|
||||||
|
-- old discriminants constrained by the new one.
|
||||||
|
|
||||||
|
elsif Nkind (Expression (D_Constraint)) = N_Identifier then
|
||||||
|
|
||||||
|
-- Find new discriminant with that name.
|
||||||
|
|
||||||
|
New_Disc := First_Discriminant (Derived_Type);
|
||||||
|
while Present (New_Disc) loop
|
||||||
|
exit when
|
||||||
|
Chars (New_Disc) = Chars (Expression (D_Constraint));
|
||||||
|
Next_Discriminant (New_Disc);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
if Present (New_Disc) then
|
||||||
|
|
||||||
|
-- Verify that the new discriminant renames
|
||||||
|
-- some discriminant of the parent type, and
|
||||||
|
-- associate the new discriminant with an old
|
||||||
|
-- one that it renames (may be more than one).
|
||||||
|
|
||||||
|
declare
|
||||||
|
Selector : Node_Id;
|
||||||
|
|
||||||
|
begin
|
||||||
|
Selector := First (Selector_Names (D_Constraint));
|
||||||
|
|
||||||
|
while Present (Selector) loop
|
||||||
|
Old_Disc := First_Discriminant (Parent_Type);
|
||||||
|
|
||||||
|
while Present (Old_Disc) loop
|
||||||
|
exit when Chars (Old_Disc) = Chars (Selector);
|
||||||
|
Next_Discriminant (Old_Disc);
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
if Present (Old_Disc) then
|
||||||
|
Set_Corresponding_Discriminant
|
||||||
|
(New_Disc, Old_Disc);
|
||||||
|
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next (Selector);
|
||||||
|
end loop;
|
||||||
|
end;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
if Nkind (D_Constraint) = N_Identifier
|
Next (D_Constraint);
|
||||||
and then Chars (D_Constraint) /=
|
|
||||||
Chars (Defining_Identifier (Disc_Spec))
|
|
||||||
then
|
|
||||||
Error_Msg_N ("new discriminants must constrain old ones",
|
|
||||||
D_Constraint);
|
|
||||||
else
|
|
||||||
Set_Corresponding_Discriminant (New_Disc, Old_Disc);
|
|
||||||
end if;
|
|
||||||
|
|
||||||
Next_Discriminant (Old_Disc);
|
|
||||||
Next_Discriminant (New_Disc);
|
|
||||||
Next (Disc_Spec);
|
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
if Present (Old_Disc) or else Present (Disc_Spec) then
|
New_Disc := First_Discriminant (Derived_Type);
|
||||||
Error_Msg_N ("discriminant mismatch in derivation", N);
|
while Present (New_Disc) loop
|
||||||
end if;
|
if No (Corresponding_Discriminant (New_Disc)) then
|
||||||
|
Error_Msg_NE
|
||||||
|
("new discriminant& must constraint old one",
|
||||||
|
N, New_Disc);
|
||||||
|
elsif not
|
||||||
|
Subtypes_Statically_Compatible (
|
||||||
|
Etype (New_Disc),
|
||||||
|
Etype (Corresponding_Discriminant (New_Disc)))
|
||||||
|
then
|
||||||
|
Error_Msg_NE
|
||||||
|
("& not statically compatible with parent discriminant",
|
||||||
|
N, New_Disc);
|
||||||
|
|
||||||
|
end if;
|
||||||
|
|
||||||
|
Next_Discriminant (New_Disc);
|
||||||
|
end loop;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
elsif Present (Discriminant_Specifications (N)) then
|
elsif Present (Discriminant_Specifications (N)) then
|
||||||
|
@ -4956,6 +5076,9 @@ package body Sem_Ch3 is
|
||||||
N);
|
N);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
|
-- The entity chain of the derived type includes the new
|
||||||
|
-- discriminants but shares operations with the parent.
|
||||||
|
|
||||||
if Present (Discriminant_Specifications (N)) then
|
if Present (Discriminant_Specifications (N)) then
|
||||||
Old_Disc := First_Discriminant (Parent_Type);
|
Old_Disc := First_Discriminant (Parent_Type);
|
||||||
while Present (Old_Disc) loop
|
while Present (Old_Disc) loop
|
||||||
|
@ -4983,6 +5106,13 @@ package body Sem_Ch3 is
|
||||||
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
|
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
|
||||||
|
|
||||||
Set_Has_Completion (Derived_Type);
|
Set_Has_Completion (Derived_Type);
|
||||||
|
|
||||||
|
if Corr_Decl_Needed then
|
||||||
|
Set_Stored_Constraint (Derived_Type, New_Constraint);
|
||||||
|
Insert_After (N, Corr_Decl);
|
||||||
|
Analyze (Corr_Decl);
|
||||||
|
Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
|
||||||
|
end if;
|
||||||
end Build_Derived_Concurrent_Type;
|
end Build_Derived_Concurrent_Type;
|
||||||
|
|
||||||
------------------------------------
|
------------------------------------
|
||||||
|
|
|
@ -6850,15 +6850,16 @@ package Sinfo is
|
||||||
-- SCIL Nodes --
|
-- SCIL Nodes --
|
||||||
-----------------
|
-----------------
|
||||||
|
|
||||||
-- SCIL nodes are special nodes added to the tree when the CodePeer mode
|
-- SCIL nodes are special nodes added to the tree when the CodePeer
|
||||||
-- is active. They help CodePeer backend to locate nodes that require
|
-- mode is active. They help the CodePeer backend to locate nodes that
|
||||||
-- special processing.
|
-- require special processing.
|
||||||
|
|
||||||
-- Where is the detailed description of what these nodes are for??? The
|
-- Major documentation on the general design of the SCIL interface, and
|
||||||
-- above is not sufficient. The description should be here, or perhaps
|
-- in particular detailed description of these nodes is missing and is
|
||||||
-- it could be in a new Sem_SCIL unit, with a pointer from here. But
|
-- to be supplied in the future, when the design has finalized ???
|
||||||
-- right now I am afraid this documentation is missing and the purpose
|
|
||||||
-- of these nodes remains secret???
|
-- Meanwhile these nodes should be considered in experimental form, and
|
||||||
|
-- should be ignored by all code generating back ends. ???
|
||||||
|
|
||||||
-- N_SCIL_Dispatch_Table_Object_Init
|
-- N_SCIL_Dispatch_Table_Object_Init
|
||||||
-- Sloc references a declaration node containing a dispatch table
|
-- Sloc references a declaration node containing a dispatch table
|
||||||
|
|
Loading…
Reference in New Issue