procedure Check_Indexing_Functions;
-- Check that the function in Constant_Indexing or Variable_Indexing
-- attribute has the proper type structure. If the name is overloaded,
- -- check that all interpretations are legal.
+ -- check that some interpretation is legal.
procedure Check_Iterator_Functions;
-- Check that there is a single function in Default_Iterator attribute
------------------------------
procedure Check_Indexing_Functions is
+ Indexing_Found : Boolean;
procedure Check_One_Function (Subp : Entity_Id);
-- Check one possible interpretation
Aspect_Iterator_Element);
begin
- if not Check_Primitive_Function (Subp) then
+ 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);
+ Subp, Ent);
end if;
-- An indexing function must return either the default element of
- -- the container, or a reference type.
+ -- the container, or a reference type. For variable indexing it
+ -- must be latter.
if Present (Default_Element) then
Analyze (Default_Element);
if Is_Entity_Name (Default_Element)
and then Covers (Entity (Default_Element), Etype (Subp))
then
+ Indexing_Found := True;
return;
end if;
end if;
- -- Otherwise the return type must be a reference type.
+ -- For variable_indexing the return type must be a reference type.
- if not Has_Implicit_Dereference (Etype (Subp)) then
+ 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);
+
+ else
+ Indexing_Found := True;
end if;
end Check_One_Function;
It : Interp;
begin
+ Indexing_Found := False;
Get_First_Interp (Expr, I, It);
while Present (It.Nam) loop
Get_Next_Interp (I, It);
end loop;
+ if not Indexing_Found then
+ Error_Msg_NE (
+ "aspect Indexing requires a function that applies to type&",
+ Expr, Ent);
+ end if;
end;
end if;
end Check_Indexing_Functions;
-- so far by the compiler in this routine.
begin
- -- Aspect is an Ada 2012 feature. Nothing to do here if the list of
- -- actuals is empty.Note that there is no need to check dimensions for
- -- calls that don't come from source.
+ -- Aspect is an Ada 2012 feature. Note that there is no need to check
+ -- dimensions for calls that don't come from source.
if Ada_Version < Ada_2012
or else not Comes_From_Source (N)
- or else Is_Empty_List (Actuals)
then
return;
end if;
- -- Special processing for elementary functions
-
- -- For Sqrt call, the resulting dimensions equal to half the dimensions
- -- of the actual. For all other elementary calls, this routine check
- -- that every actual is dimensionless.
-
- if Nkind (N) = N_Function_Call then
- Elementary_Function_Calls : declare
- Dims_Of_Call : Dimension_Type;
- Ent : Entity_Id := Nam;
+ -- Check the dimensions of the actuals, if any
- function Is_Elementary_Function_Entity
- (Sub_Id : Entity_Id) return Boolean;
- -- Given Sub_Id, the original subprogram entity, return True if
- -- call is to an elementary function
- -- (see Ada.Numerics.Generic_Elementary_Functions).
+ if not Is_Empty_List (Actuals) then
+ -- Special processing for elementary functions
- -----------------------------------
- -- Is_Elementary_Function_Entity --
- -----------------------------------
+ -- For Sqrt call, the resulting dimensions equal to half the
+ -- dimensions of the actual. For all other elementary calls, this
+ -- routine check that every actual is dimensionless.
- function Is_Elementary_Function_Entity
- (Sub_Id : Entity_Id) return Boolean
- is
- Loc : constant Source_Ptr := Sloc (Sub_Id);
+ if Nkind (N) = N_Function_Call then
+ Elementary_Function_Calls : declare
+ Dims_Of_Call : Dimension_Type;
+ Ent : Entity_Id := Nam;
- begin
- -- Is function entity in
- -- Ada.Numerics.Generic_Elementary_Functions?
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean;
+ -- Given Sub_Id, the original subprogram entity, return True if
+ -- call is to an elementary function
+ -- (see Ada.Numerics.Generic_Elementary_Functions).
- return
- Loc > No_Location
- and then
- Is_RTU
- (Cunit_Entity (Get_Source_Unit (Loc)),
- Ada_Numerics_Generic_Elementary_Functions);
- end Is_Elementary_Function_Entity;
+ -----------------------------------
+ -- Is_Elementary_Function_Entity --
+ -----------------------------------
- -- Start of processing for Elementary_Function_Calls
+ function Is_Elementary_Function_Entity
+ (Sub_Id : Entity_Id) return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (Sub_Id);
- begin
- -- Get the original subprogram entity following the renaming chain
+ begin
+ -- Is function entity in
+ -- Ada.Numerics.Generic_Elementary_Functions?
- if Present (Alias (Ent)) then
- Ent := Alias (Ent);
- end if;
+ return
+ Loc > No_Location
+ and then
+ Is_RTU
+ (Cunit_Entity (Get_Source_Unit (Loc)),
+ Ada_Numerics_Generic_Elementary_Functions);
+ end Is_Elementary_Function_Entity;
- -- Check the call is an Elementary function call
+ -- Start of processing for Elementary_Function_Calls
- if Is_Elementary_Function_Entity (Ent) then
+ begin
+ -- Get the original subprogram entity following the renaming
+ -- chain.
- -- Sqrt function call case
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
- if Chars (Ent) = Name_Sqrt then
- Dims_Of_Call := Dimensions_Of (First_Actual (N));
+ -- Check the call is an Elementary function call
- -- Eavluates the resulting dimensions (i.e. half the
- -- dimensions of the actual).
+ if Is_Elementary_Function_Entity (Ent) then
+ -- Sqrt function call case
- if Exists (Dims_Of_Call) then
- for Position in Dims_Of_Call'Range loop
- Dims_Of_Call (Position) :=
- Dims_Of_Call (Position) *
- Rational'(Numerator => 1,
- Denominator => 2);
- end loop;
+ if Chars (Ent) = Name_Sqrt then
+ Dims_Of_Call := Dimensions_Of (First_Actual (N));
- Set_Dimensions (N, Dims_Of_Call);
- end if;
+ -- Evaluates the resulting dimensions (i.e. half the
+ -- dimensions of the actual).
- -- All other elementary functions case. Note that every actual
- -- here should be dimensionless.
+ if Exists (Dims_Of_Call) then
+ for Position in Dims_Of_Call'Range loop
+ Dims_Of_Call (Position) :=
+ Dims_Of_Call (Position) *
+ Rational'(Numerator => 1,
+ Denominator => 2);
+ end loop;
- else
- Actual := First_Actual (N);
- while Present (Actual) loop
- if Exists (Dimensions_Of (Actual)) then
+ Set_Dimensions (N, Dims_Of_Call);
+ end if;
- -- Check if error has already been encountered so far
+ -- All other elementary functions case. Note that every
+ -- actual here should be dimensionless.
- if not Error_Detected then
- Error_Msg_NE ("dimensions mismatch in call of&",
- N, Name (N));
- Error_Detected := True;
+ else
+ Actual := First_Actual (N);
+ while Present (Actual) loop
+ if Exists (Dimensions_Of (Actual)) then
+
+ -- Check if error has already been encountered so
+ -- far.
+
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in call of&",
+ N, Name (N));
+ Error_Detected := True;
+ end if;
+
+ Error_Msg_N ("\expected dimension [], found " &
+ Dimensions_Msg_Of (Actual),
+ Actual);
end if;
- Error_Msg_N ("\expected dimension [], found " &
- Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ Next_Actual (Actual);
+ end loop;
+ end if;
- Next_Actual (Actual);
- end loop;
- end if;
+ -- Nothing more to do for elementary functions
- -- Nothing more to do for elementary functions
+ return;
+ end if;
+ end Elementary_Function_Calls;
+ end if;
- return;
- end if;
- end Elementary_Function_Calls;
- end if;
+ -- General case. Check, for each parameter, the dimensions of the
+ -- actual and its corresponding formal match. Otherwise, complain.
- -- General case. Check, for each parameter, the dimensions of the actual
- -- and its corresponding formal match. Otherwise, complain.
+ Actual := First_Actual (N);
+ Formal := First_Formal (Nam);
- Actual := First_Actual (N);
- Formal := First_Formal (Nam);
+ while Present (Formal) loop
+ Formal_Typ := Etype (Formal);
+ Dims_Of_Formal := Dimensions_Of (Formal_Typ);
- while Present (Formal) loop
- Formal_Typ := Etype (Formal);
- Dims_Of_Formal := Dimensions_Of (Formal_Typ);
+ -- If the formal is not dimensionless, check dimensions of formal
+ -- and actual match. Otherwise, complain.
- -- If the formal is not dimensionless, check dimensions of formal and
- -- actual match. Otherwise, complain.
+ if Exists (Dims_Of_Formal)
+ and then Dimensions_Of (Actual) /= Dims_Of_Formal
+ then
+ -- Check if an error has already been encountered so far
- if Exists (Dims_Of_Formal)
- and then Dimensions_Of (Actual) /= Dims_Of_Formal
- then
- -- Check if an error has already been encountered so far
+ if not Error_Detected then
+ Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
+ Error_Detected := True;
+ end if;
- if not Error_Detected then
- Error_Msg_NE ("dimensions mismatch in& call", N, Name (N));
- Error_Detected := True;
+ Error_Msg_N ("\expected dimension " &
+ Dimensions_Msg_Of (Formal_Typ) & ", found " &
+ Dimensions_Msg_Of (Actual),
+ Actual);
end if;
- Error_Msg_N ("\expected dimension " &
- Dimensions_Msg_Of (Formal_Typ) & ", found " &
- Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+ end loop;
+ end if;
- Next_Actual (Actual);
- Next_Formal (Formal);
- end loop;
+ -- For function calls, propagate the dimensions from the returned type
+
+ if Nkind (N) = N_Function_Call then
+ Analyze_Dimension_Has_Etype (N);
+ end if;
end Analyze_Dimension_Call;
---------------------------------------------
projects / platform / upstream / gcc.git / commitdiff