+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>
* sem_aggr.adb (Get_Value): A named association in a record aggregate
Sub_Ref :=
Make_Attribute_Reference (Loc,
- Prefix => Sub,
+ Prefix => Sub,
Attribute_Name => Name_Access);
-- We set the type of the access reference to the already generated
Agg :=
Make_Aggregate (Loc,
- Expressions =>
- New_List (
- Obj_Ref, Sub_Ref));
+ Expressions => New_List (Obj_Ref, Sub_Ref));
Rewrite (N, Agg);
-
Analyze_And_Resolve (N, E_T);
- -- For subsequent analysis, the node must retain its type.
- -- The backend will replace it with the equivalent type where
- -- needed.
+ -- For subsequent analysis, the node must retain its type. The backend
+ -- will replace it with the equivalent type where needed.
Set_Etype (N, Typ);
end Expand_Access_To_Protected_Op;
Params := New_List;
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);
if Ekind (Sub) = E_Procedure then
return N;
else
return
- Unchecked_Convert_To (Corresponding_Record_Type (Typ),
- New_Copy_Tree (N));
+ Unchecked_Convert_To
+ (Corresponding_Record_Type (Typ), New_Copy_Tree (N));
end if;
end Convert_Concurrent;
procedure List_Bad_Compilations;
-- 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;
-- Flag used to make sure Makeusg is call at most once
O_File : out File_Name_Type;
O_Stamp : out Time_Stamp_Type)
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;
-- 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
-- services, but this causes the whole compiler to be dragged along
-- 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 --
--------------------
end if;
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
-- Make sure that in case of failure, the temp files will be deleted
with Debug;
with Osint; use Osint;
with Output; use Output;
+with Opt; use Opt;
with Prj.Ext;
with Prj.Util;
with Snames; use Snames;
end;
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 --
----------
return Result;
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;
------------------------------------------------------------------------------
with Namet; use Namet;
+with Opt;
with Osint;
with Prj; use Prj;
with Types; use Types;
procedure Inform (N : File_Name_Type; Msg : String);
-- 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;
-- Verify that an external assignment switch is syntactically correct
--
-- been entered by a call to Prj.Ext.Add, so that in a project
-- 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
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return String_List;
begin
-- 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
-- one passed to Recursive_Add have never been visited before, but
-- The list of all directly imported projects, if any
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 --
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
- D_Constraint : Node_Id;
- Disc_Spec : Node_Id;
- Old_Disc : Entity_Id;
- New_Disc : Entity_Id;
-
- Constraint_Present : constant Boolean :=
- Nkind (Subtype_Indication (Type_Definition (N)))
- = N_Subtype_Indication;
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Corr_Record : constant Entity_Id
+ := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+ 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
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
if Present (Discriminant_Specifications (N)) then
Push_Scope (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;
elsif Constraint_Present then
end;
end if;
- -- All attributes are inherited from parent. In particular,
- -- entries and the corresponding record type are the same.
- -- Discriminants may be renamed, and must be treated separately.
+ -- By default, operations and private data are inherited from parent.
+ -- However, in the presence of bound discriminants, a new corresponding
+ -- record will be created, see below.
Set_Has_Discriminants
(Derived_Type, Has_Discriminants (Parent_Type));
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
- 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));
+ Old_Disc := First_Discriminant (Parent_Type);
- if not Subtypes_Statically_Compatible (
- Etype (Discriminant_Type (Disc_Spec)),
- Etype (Old_Disc))
- then
- Error_Msg_N
- ("not statically compatible with parent discriminant",
- Discriminant_Type (Disc_Spec));
+ while Present (D_Constraint) loop
+ if Nkind (D_Constraint) /= N_Discriminant_Association then
+
+ -- Positional constraint. If it is a reference to a
+ -- new discriminant, it constrains the corresponding
+ -- old one.
+
+ 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;
- if Nkind (D_Constraint) = N_Identifier
- and then Chars (D_Constraint) /=
- Chars (Defining_Identifier (Disc_Spec))
+ Next (D_Constraint);
+ end loop;
+
+ New_Disc := First_Discriminant (Derived_Type);
+ while Present (New_Disc) loop
+ 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_N ("new discriminants must constrain old ones",
- D_Constraint);
- else
- Set_Corresponding_Discriminant (New_Disc, Old_Disc);
+ Error_Msg_NE
+ ("& not statically compatible with parent discriminant",
+ N, New_Disc);
+
end if;
- Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
- Next (Disc_Spec);
end loop;
-
- if Present (Old_Disc) or else Present (Disc_Spec) then
- Error_Msg_N ("discriminant mismatch in derivation", N);
- end if;
-
end if;
elsif Present (Discriminant_Specifications (N)) then
N);
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
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
Set_Last_Entity (Derived_Type, Last_Entity (Parent_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;
------------------------------------
-- SCIL Nodes --
-----------------
- -- SCIL nodes are special nodes added to the tree when the CodePeer mode
- -- is active. They help CodePeer backend to locate nodes that require
- -- special processing.
-
- -- Where is the detailed description of what these nodes are for??? The
- -- above is not sufficient. The description should be here, or perhaps
- -- it could be in a new Sem_SCIL unit, with a pointer from here. But
- -- right now I am afraid this documentation is missing and the purpose
- -- of these nodes remains secret???
+ -- SCIL nodes are special nodes added to the tree when the CodePeer
+ -- mode is active. They help the CodePeer backend to locate nodes that
+ -- require special processing.
+
+ -- Major documentation on the general design of the SCIL interface, and
+ -- in particular detailed description of these nodes is missing and is
+ -- to be supplied in the future, when the design has finalized ???
+
+ -- 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
-- Sloc references a declaration node containing a dispatch table
projects / platform / upstream / gcc.git / commitdiff