+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.
-- 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
-- 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
-- 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;
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;
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
-- 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
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,
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 =>
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.
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.
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);
-- 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;
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 ???
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;
-- 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
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;
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
-- 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;
projects / platform / upstream / gcc.git / commitdiff