[multiple changes]
2014-07-31 Gary Dismukes <dismukes@adacore.com> * exp_util.adb: Minor reformatting. 2014-07-31 Vincent Celier <celier@adacore.com> * errutil.adb (Error_Msg): Make sure that all components of the error message object are initialized. 2014-07-31 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Try_Container_Indexing): If the container type is class-wide, use specific type to locate iteration primitives. * sem_ch13.adb (Check_Indexing_Functions): Add legality checks for rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure. Minor error message reformating. * exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator aspect for a derived type. 2014-07-31 Robert Dewar <dewar@adacore.com> * debug.adb: Document debug flag d.X. From-SVN: r213346
This commit is contained in:
Arnaud Charlet
parent
3dddb11ea4
commit
f3296dd398
|
|
@ -1,3 +1,26 @@
|
|||
2014-07-31 Gary Dismukes <dismukes@adacore.com>
|
||||
|
||||
* exp_util.adb: Minor reformatting.
|
||||
|
||||
2014-07-31 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* errutil.adb (Error_Msg): Make sure that all components of
|
||||
the error message object are initialized.
|
||||
|
||||
2014-07-31 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Try_Container_Indexing): If the container type is
|
||||
class-wide, use specific type to locate iteration primitives.
|
||||
* sem_ch13.adb (Check_Indexing_Functions): Add legality checks for
|
||||
rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure.
|
||||
Minor error message reformating.
|
||||
* exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator
|
||||
aspect for a derived type.
|
||||
|
||||
2014-07-31 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* debug.adb: Document debug flag d.X.
|
||||
|
||||
2014-07-31 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_util.ads (Find_Specific_Type): Moved here from exp_disp.adb.
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ package body Debug is
|
|||
-- d.U Ignore indirect calls for static elaboration
|
||||
-- d.V
|
||||
-- d.W Print out debugging information for Walk_Library_Items
|
||||
-- d.X
|
||||
-- d.X Old treatment of indexing aspects
|
||||
-- d.Y
|
||||
-- d.Z
|
||||
|
||||
|
|
@ -685,6 +685,12 @@ package body Debug is
|
|||
-- the order in which units are walked. This is primarily for use in
|
||||
-- debugging CodePeer mode.
|
||||
|
||||
-- d.X A previous version of GNAT allowed indexing aspects to be
|
||||
-- redefined on derived container types, while the default iterator
|
||||
-- was inherited from the aprent type. This non-standard extension
|
||||
-- is preserved temporarily for use by the modelling project under
|
||||
-- debug flag d.X.
|
||||
|
||||
-- d1 Error messages have node numbers where possible. Normally error
|
||||
-- messages have only source locations. This option is useful when
|
||||
-- debugging errors caused by expanded code, where the source location
|
||||
|
|
|
|||
|
|
@ -201,24 +201,27 @@ package body Errutil is
|
|||
|
||||
-- Otherwise build error message object for new message
|
||||
|
||||
Errors.Increment_Last;
|
||||
Cur_Msg := Errors.Last;
|
||||
Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen));
|
||||
Errors.Table (Cur_Msg).Next := No_Error_Msg;
|
||||
Errors.Table (Cur_Msg).Sptr := Sptr;
|
||||
Errors.Table (Cur_Msg).Optr := Optr;
|
||||
Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr);
|
||||
Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr);
|
||||
Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
|
||||
Errors.Table (Cur_Msg).Style := Is_Style_Msg;
|
||||
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
|
||||
Errors.Table (Cur_Msg).Info := Is_Info_Msg;
|
||||
Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
|
||||
Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
|
||||
Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
|
||||
Errors.Table (Cur_Msg).Msg_Cont := Continuation;
|
||||
Errors.Table (Cur_Msg).Deleted := False;
|
||||
Errors.Append
|
||||
(New_Val =>
|
||||
(Text => new String'(Msg_Buffer (1 .. Msglen)),
|
||||
Next => No_Error_Msg,
|
||||
Prev => No_Error_Msg,
|
||||
Sfile => Get_Source_File_Index (Sptr),
|
||||
Sptr => Sptr,
|
||||
Optr => Optr,
|
||||
Line => Get_Physical_Line_Number (Sptr),
|
||||
Col => Get_Column_Number (Sptr),
|
||||
Warn => Is_Warning_Msg,
|
||||
Info => Is_Info_Msg,
|
||||
Warn_Err => Warning_Mode = Treat_As_Error,
|
||||
Warn_Chr => Warning_Msg_Char,
|
||||
Style => Is_Style_Msg,
|
||||
Serious => Is_Serious_Error,
|
||||
Uncond => Is_Unconditional_Msg,
|
||||
Msg_Cont => Continuation,
|
||||
Deleted => False));
|
||||
|
||||
Cur_Msg := Errors.Last;
|
||||
Prev_Msg := No_Error_Msg;
|
||||
Next_Msg := First_Error_Msg;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ with Atree; use Atree;
|
|||
with Checks; use Checks;
|
||||
with Debug; use Debug;
|
||||
with Einfo; use Einfo;
|
||||
with Elists; use Elists;
|
||||
with Errout; use Errout;
|
||||
with Exp_Aggr; use Exp_Aggr;
|
||||
with Exp_Ch6; use Exp_Ch6;
|
||||
|
|
@ -58,6 +59,7 @@ with Stand; use Stand;
|
|||
with Stringt; use Stringt;
|
||||
with Targparm; use Targparm;
|
||||
with Tbuild; use Tbuild;
|
||||
with Uintp; use Uintp;
|
||||
with Validsw; use Validsw;
|
||||
|
||||
package body Exp_Ch5 is
|
||||
|
|
@ -3292,17 +3294,90 @@ package body Exp_Ch5 is
|
|||
-- type of the iterator must be obtained from the aspect.
|
||||
|
||||
if Of_Present (I_Spec) then
|
||||
declare
|
||||
Default_Iter : constant Entity_Id :=
|
||||
Entity
|
||||
(Find_Value_Of_Aspect
|
||||
(Etype (Container),
|
||||
Aspect_Default_Iterator));
|
||||
|
||||
Handle_Of : declare
|
||||
Default_Iter : Entity_Id;
|
||||
Container_Arg : Node_Id;
|
||||
Ent : Entity_Id;
|
||||
|
||||
function Get_Default_Iterator
|
||||
(T : Entity_Id) return Entity_Id;
|
||||
-- If the container is a derived type, the aspect holds the
|
||||
-- parent operation. The required one is a primitive of the
|
||||
-- derived type and is either inherited or overridden.
|
||||
|
||||
--------------------------
|
||||
-- Get_Default_Iterator --
|
||||
--------------------------
|
||||
|
||||
function Get_Default_Iterator
|
||||
(T : Entity_Id) return Entity_Id
|
||||
is
|
||||
Iter : constant Entity_Id :=
|
||||
Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator));
|
||||
Prim : Elmt_Id;
|
||||
Op : Entity_Id;
|
||||
|
||||
begin
|
||||
Container_Arg := New_Copy_Tree (Container);
|
||||
|
||||
-- A previous version of GNAT allowed indexing aspects to
|
||||
-- be redefined on derived container types, while the
|
||||
-- default iterator was inherited from the aprent type.
|
||||
-- This non-standard extension is preserved temporarily for
|
||||
-- use by the modelling project under debug flag d.X.
|
||||
|
||||
if Debug_Flag_Dot_XX then
|
||||
if Base_Type (Etype (Container)) /=
|
||||
Base_Type (Etype (First_Formal (Iter)))
|
||||
then
|
||||
Container_Arg :=
|
||||
Make_Type_Conversion (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of
|
||||
(Etype (First_Formal (Iter)), Loc),
|
||||
Expression => Container_Arg);
|
||||
end if;
|
||||
|
||||
return Iter;
|
||||
|
||||
elsif Is_Derived_Type (T) then
|
||||
|
||||
-- The default iterator must be a primitive operation
|
||||
-- of the type, at the same dispatch slot position.
|
||||
|
||||
Prim := First_Elmt (Primitive_Operations (T));
|
||||
while Present (Prim) loop
|
||||
Op := Node (Prim);
|
||||
|
||||
if Chars (Op) = Chars (Iter)
|
||||
and then DT_Position (Op) = DT_Position (Iter)
|
||||
then
|
||||
return Op;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
end loop;
|
||||
|
||||
-- default iterator must exist.
|
||||
|
||||
pragma Assert (False);
|
||||
|
||||
else -- not a derived type
|
||||
return Iter;
|
||||
end if;
|
||||
end Get_Default_Iterator;
|
||||
|
||||
-- Start of processing for Handle_Of
|
||||
|
||||
begin
|
||||
if Is_Class_Wide_Type (Container_Typ) then
|
||||
Default_Iter :=
|
||||
Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
|
||||
|
||||
else
|
||||
Default_Iter := Get_Default_Iterator (Etype (Container));
|
||||
end if;
|
||||
|
||||
Cursor := Make_Temporary (Loc, 'C');
|
||||
|
||||
-- For an container element iterator, the iterator type
|
||||
|
|
@ -3320,24 +3395,7 @@ package body Exp_Ch5 is
|
|||
Pack := Scope (Root_Type (Etype (Iter_Type)));
|
||||
|
||||
-- Rewrite domain of iteration as a call to the default
|
||||
-- iterator for the container type. If the container is
|
||||
-- a derived type and the aspect is inherited, convert
|
||||
-- container to parent type. The Cursor type is also
|
||||
-- inherited from the scope of the parent.
|
||||
|
||||
if Base_Type (Etype (Container)) =
|
||||
Base_Type (Etype (First_Formal (Default_Iter)))
|
||||
then
|
||||
Container_Arg := New_Copy_Tree (Container);
|
||||
|
||||
else
|
||||
Container_Arg :=
|
||||
Make_Type_Conversion (Loc,
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of
|
||||
(Etype (First_Formal (Default_Iter)), Loc),
|
||||
Expression => New_Copy_Tree (Container));
|
||||
end if;
|
||||
-- iterator for the container type.
|
||||
|
||||
Rewrite (Name (I_Spec),
|
||||
Make_Function_Call (Loc,
|
||||
|
|
@ -3367,9 +3425,9 @@ package body Exp_Ch5 is
|
|||
Decl :=
|
||||
Make_Object_Renaming_Declaration (Loc,
|
||||
Defining_Identifier => Id,
|
||||
Subtype_Mark =>
|
||||
Subtype_Mark =>
|
||||
New_Occurrence_Of (Element_Type, Loc),
|
||||
Name =>
|
||||
Name =>
|
||||
Make_Indexed_Component (Loc,
|
||||
Prefix => Relocate_Node (Container_Arg),
|
||||
Expressions =>
|
||||
|
|
@ -3415,7 +3473,7 @@ package body Exp_Ch5 is
|
|||
else
|
||||
Prepend_To (Stats, Decl);
|
||||
end if;
|
||||
end;
|
||||
end Handle_Of;
|
||||
|
||||
-- X in Iterate (S) : type of iterator is type of explicitly
|
||||
-- given Iterate function, and the loop variable is the cursor.
|
||||
|
|
|
|||
|
|
@ -786,7 +786,7 @@ package body Exp_Util is
|
|||
if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
|
||||
Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
|
||||
|
||||
-- For deallocation of class wide types we obtain the value of
|
||||
-- For deallocation of class-wide types we obtain the value of
|
||||
-- alignment from the Type Specific Record of the deallocated object.
|
||||
-- This is needed because the frontend expansion of class-wide types
|
||||
-- into equivalent types confuses the backend.
|
||||
|
|
@ -5860,7 +5860,7 @@ package body Exp_Util is
|
|||
|
||||
Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
|
||||
|
||||
-- A class_wide equivalent type does not require initialization
|
||||
-- A class-wide equivalent type does not require initialization
|
||||
|
||||
Set_Suppress_Initialization (Equiv_Type);
|
||||
|
||||
|
|
@ -6097,7 +6097,7 @@ package body Exp_Util is
|
|||
-- 2. If Expr is a unconstrained discriminated type expression, creates
|
||||
-- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
|
||||
|
||||
-- 3. If Expr is class-wide, creates an implicit class wide subtype
|
||||
-- 3. If Expr is class-wide, creates an implicit class-wide subtype
|
||||
|
||||
function Make_Subtype_From_Expr
|
||||
(E : Node_Id;
|
||||
|
|
@ -6186,8 +6186,8 @@ package body Exp_Util is
|
|||
|
||||
if Expander_Active and then Tagged_Type_Expansion then
|
||||
|
||||
-- If this is the class_wide type of a completion that is a
|
||||
-- record subtype, set the type of the class_wide type to be
|
||||
-- If this is the class-wide type of a completion that is a
|
||||
-- record subtype, set the type of the class-wide type to be
|
||||
-- the full base type, for use in the expanded code for the
|
||||
-- equivalent type. Should this be done earlier when the
|
||||
-- completion is analyzed ???
|
||||
|
|
|
|||
|
|
@ -1671,7 +1671,9 @@ package body Sem_Ch13 is
|
|||
and then not (Is_Type (E)
|
||||
and then Is_Tagged_Type (E))
|
||||
then
|
||||
Error_Msg_N ("indexing applies to a tagged type", N);
|
||||
Error_Msg_N
|
||||
("indexing aspect can only apply to a tagged type",
|
||||
Aspect);
|
||||
goto Continue;
|
||||
end if;
|
||||
|
||||
|
|
@ -3471,53 +3473,138 @@ package body Sem_Ch13 is
|
|||
-- Check one possible interpretation. Sets Indexing_Found True if an
|
||||
-- indexing function is found.
|
||||
|
||||
procedure Illegal_Indexing (Msg : String);
|
||||
-- Diagnose illegal indexing function if not overloaded. In the
|
||||
-- overloaded case indicate that no legal interpretation exists.
|
||||
|
||||
------------------------
|
||||
-- Check_One_Function --
|
||||
------------------------
|
||||
|
||||
procedure Check_One_Function (Subp : Entity_Id) is
|
||||
Default_Element : constant Node_Id :=
|
||||
Find_Value_Of_Aspect
|
||||
(Etype (First_Formal (Subp)),
|
||||
Aspect_Iterator_Element);
|
||||
Default_Element : Node_Id;
|
||||
Ret_Type : constant Entity_Id := Etype (Subp);
|
||||
|
||||
begin
|
||||
if not Is_Overloadable (Subp) then
|
||||
Illegal_Indexing ("illegal indexing function for type&");
|
||||
return;
|
||||
|
||||
elsif Scope (Subp) /= Current_Scope then
|
||||
Illegal_Indexing
|
||||
("indexing function must be declared in scope of type&");
|
||||
return;
|
||||
|
||||
elsif No (First_Formal (Subp)) then
|
||||
Illegal_Indexing
|
||||
("Indexing requires a function that applies to type&");
|
||||
return;
|
||||
|
||||
elsif No (Next_Formal (First_Formal (Subp))) then
|
||||
Illegal_Indexing
|
||||
("indexing function must have at least two parameters");
|
||||
return;
|
||||
|
||||
elsif Is_Derived_Type (Ent) then
|
||||
if (Attr = Name_Constant_Indexing
|
||||
and then Present
|
||||
(Find_Aspect (Etype (Ent), Aspect_Constant_Indexing)))
|
||||
|
||||
or else (Attr = Name_Variable_Indexing
|
||||
and then Present
|
||||
(Find_Aspect (Etype (Ent), Aspect_Variable_Indexing)))
|
||||
then
|
||||
if Debug_Flag_Dot_XX then
|
||||
null;
|
||||
|
||||
else
|
||||
Illegal_Indexing
|
||||
("indexing function already inherited "
|
||||
& "from parent type");
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if not Check_Primitive_Function (Subp)
|
||||
and then not Is_Overloaded (Expr)
|
||||
then
|
||||
Error_Msg_NE
|
||||
("aspect Indexing requires a function that applies to type&",
|
||||
Subp, Ent);
|
||||
Illegal_Indexing
|
||||
("Indexing aspect requires a function that applies to type&");
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- An indexing function must return either the default element of
|
||||
-- the container, or a reference type. For variable indexing it
|
||||
-- must be the latter.
|
||||
|
||||
Default_Element :=
|
||||
Find_Value_Of_Aspect
|
||||
(Etype (First_Formal (Subp)), Aspect_Iterator_Element);
|
||||
|
||||
if Present (Default_Element) then
|
||||
Analyze (Default_Element);
|
||||
|
||||
if Is_Entity_Name (Default_Element)
|
||||
and then Covers (Entity (Default_Element), Etype (Subp))
|
||||
and then not Covers (Entity (Default_Element), Ret_Type)
|
||||
and then False
|
||||
then
|
||||
Indexing_Found := True;
|
||||
Illegal_Indexing
|
||||
("wrong return type for indexing function");
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- For variable_indexing the return type must be a reference type
|
||||
|
||||
if Attr = Name_Variable_Indexing
|
||||
and then not Has_Implicit_Dereference (Etype (Subp))
|
||||
then
|
||||
Error_Msg_N
|
||||
("function for indexing must return a reference type", Subp);
|
||||
if Attr = Name_Variable_Indexing then
|
||||
if not Has_Implicit_Dereference (Ret_Type) then
|
||||
Illegal_Indexing
|
||||
("variable indexing must return a reference type");
|
||||
return;
|
||||
|
||||
elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
|
||||
then
|
||||
Illegal_Indexing
|
||||
("variable indexing must return an access to variable");
|
||||
return;
|
||||
end if;
|
||||
|
||||
else
|
||||
Indexing_Found := True;
|
||||
if Has_Implicit_Dereference (Ret_Type)
|
||||
and then not
|
||||
Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
|
||||
then
|
||||
Illegal_Indexing
|
||||
("constant indexing must return an access to constant");
|
||||
return;
|
||||
|
||||
elsif Is_Access_Type (Etype (First_Formal (Subp)))
|
||||
and then not Is_Access_Constant (Etype (First_Formal (Subp)))
|
||||
then
|
||||
Illegal_Indexing
|
||||
("constant indexing must apply to an access to constant");
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- All checks succeeded.
|
||||
|
||||
Indexing_Found := True;
|
||||
end Check_One_Function;
|
||||
|
||||
-----------------------
|
||||
-- Illegal_Indexing --
|
||||
-----------------------
|
||||
|
||||
procedure Illegal_Indexing (Msg : String) is
|
||||
begin
|
||||
if not Is_Overloaded (Expr) then
|
||||
Error_Msg_NE (Msg, N, Ent);
|
||||
end if;
|
||||
end Illegal_Indexing;
|
||||
|
||||
-- Start of processing for Check_Indexing_Functions
|
||||
|
||||
begin
|
||||
|
|
|
|||
|
|
@ -6959,6 +6959,7 @@ package body Sem_Ch4 is
|
|||
Exprs : List_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
C_Type : Entity_Id;
|
||||
Assoc : List_Id;
|
||||
Disc : Entity_Id;
|
||||
Func : Entity_Id;
|
||||
|
|
@ -6966,6 +6967,14 @@ package body Sem_Ch4 is
|
|||
Indexing : Node_Id;
|
||||
|
||||
begin
|
||||
C_Type := Etype (Prefix);
|
||||
|
||||
-- If indexing a class-wide container, obtain indexing primitive
|
||||
-- from specific type.
|
||||
|
||||
if Is_Class_Wide_Type (C_Type) then
|
||||
C_Type := Etype (Base_Type (C_Type));
|
||||
end if;
|
||||
|
||||
-- Check whether type has a specified indexing aspect
|
||||
|
||||
|
|
@ -7013,10 +7022,10 @@ package body Sem_Ch4 is
|
|||
-- Additional machinery may be needed for types that have several user-
|
||||
-- defined Reference operations with different signatures ???
|
||||
|
||||
elsif Is_Derived_Type (Etype (Prefix))
|
||||
elsif Is_Derived_Type (C_Type)
|
||||
and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
|
||||
then
|
||||
Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name));
|
||||
Func := Find_Prim_Op (C_Type, Chars (Func_Name));
|
||||
Func_Name := New_Occurrence_Of (Func, Loc);
|
||||
end if;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue