[multiple changes]
2012-10-02 Bob Duff <duff@adacore.com> * checks.adb (Apply_Predicate_Check): Disable check in -gnatc mode. 2012-10-02 Vincent Pucci <pucci@adacore.com> * sem_ch6.adb (Analyze_Function_Call): Dimension propagation for function calls moved to Analyze_Dimension_Call. * sem_dim.adb (Analyze_Dimension_Call): Properly propagate the dimensions from the returned type for function calls. 2012-10-02 Vincent Celier <celier@adacore.com> * gnatcmd.adb: Take into account any configuration pragma file in the project files for gnat pretty/stub/metric. 2012-10-02 Ed Schonberg <schonberg@adacore.com> * sem_ch13.adb (Check_Indexing_Functions): Refine several tests on the legality of indexing aspects: Constant_Indexing functions do not have to return a reference type, and given an indexing aspect Func, not all overloadings of Func in the current scope need to be indexing functions. 2012-10-02 Vasiliy Fofanov <fofanov@adacore.com> * gnat_ugn.texi: Adjust docs for overflow checks to be VMS-friendly. 2012-10-02 Vincent Celier <celier@adacore.com> * switch-m.adb (Normalize_Compiler_Switches): Recognize switches -gnatox and -gnatoxx when x=0/1/2/3. From-SVN: r191960
This commit is contained in:
Arnaud Charlet
parent
5f49133f81
commit
2a7b8e181b
8 changed files with 226 additions and 137 deletions
|
|
@ -1,3 +1,36 @@
|
|||
2012-10-02 Bob Duff <duff@adacore.com>
|
||||
|
||||
* checks.adb (Apply_Predicate_Check): Disable check in -gnatc mode.
|
||||
|
||||
2012-10-02 Vincent Pucci <pucci@adacore.com>
|
||||
|
||||
* sem_ch6.adb (Analyze_Function_Call): Dimension propagation
|
||||
for function calls moved to Analyze_Dimension_Call.
|
||||
* sem_dim.adb (Analyze_Dimension_Call): Properly propagate the
|
||||
dimensions from the returned type for function calls.
|
||||
|
||||
2012-10-02 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* gnatcmd.adb: Take into account any configuration pragma file
|
||||
in the project files for gnat pretty/stub/metric.
|
||||
|
||||
2012-10-02 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch13.adb (Check_Indexing_Functions): Refine several tests
|
||||
on the legality of indexing aspects: Constant_Indexing functions
|
||||
do not have to return a reference type, and given an indexing
|
||||
aspect Func, not all overloadings of Func in the current scope
|
||||
need to be indexing functions.
|
||||
|
||||
2012-10-02 Vasiliy Fofanov <fofanov@adacore.com>
|
||||
|
||||
* gnat_ugn.texi: Adjust docs for overflow checks to be VMS-friendly.
|
||||
|
||||
2012-10-02 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* switch-m.adb (Normalize_Compiler_Switches): Recognize switches
|
||||
-gnatox and -gnatoxx when x=0/1/2/3.
|
||||
|
||||
2012-10-02 Vincent Pucci <pucci@adacore.com>
|
||||
|
||||
* sem_ch4.adb (Analyze_Indexed_Component_Form): Dimension
|
||||
|
|
|
|||
|
|
@ -2459,11 +2459,15 @@ package body Checks is
|
|||
else
|
||||
-- If the predicate is a static predicate and the operand is
|
||||
-- static, the predicate must be evaluated statically. If the
|
||||
-- evaluation fails this is a static constraint error.
|
||||
-- evaluation fails this is a static constraint error. This check
|
||||
-- is disabled in -gnatc mode, because the compiler is incapable
|
||||
-- of evaluating static expressions in that case.
|
||||
|
||||
if Is_OK_Static_Expression (N) then
|
||||
if Present (Static_Predicate (Typ)) then
|
||||
if Eval_Static_Predicate_Check (N, Typ) then
|
||||
if Operating_Mode < Generate_Code or else
|
||||
Eval_Static_Predicate_Check (N, Typ)
|
||||
then
|
||||
return;
|
||||
else
|
||||
Error_Msg_NE
|
||||
|
|
|
|||
|
|
@ -4346,7 +4346,7 @@ an assertion.
|
|||
Enable numeric overflow checking (which is not normally enabled by
|
||||
default). Note that division by zero is a separate check that is not
|
||||
controlled by this switch (division by zero checking is on by default).
|
||||
The checking mode is set to CHECKED (equivalent to @option{-gnato11}).
|
||||
The checking mode is set to CHECKED (equivalent to @option{^-gnato11^/OVERFLOW_CHECKS=11^}).
|
||||
|
||||
@item -gnatp
|
||||
@cindex @option{-gnatp} (@command{gcc})
|
||||
|
|
|
|||
|
|
@ -2311,10 +2311,15 @@ begin
|
|||
(new String'("-gnatem=" & Get_Name_String (M_File)));
|
||||
end if;
|
||||
|
||||
-- For gnatcheck, also indicate a global configuration pragmas
|
||||
-- file and, if -U is not used, a local one.
|
||||
-- For gnatcheck, gnatpp, gnatstub and gnatmetric, also
|
||||
-- indicate a global configuration pragmas file and, if -U
|
||||
-- is not used, a local one.
|
||||
|
||||
if The_Command = Check then
|
||||
if The_Command = Check or else
|
||||
The_Command = Pretty or else
|
||||
The_Command = Stub or else
|
||||
The_Command = Metric
|
||||
then
|
||||
declare
|
||||
Pkg : constant Prj.Package_Id :=
|
||||
Prj.Util.Value_Of
|
||||
|
|
|
|||
|
|
@ -1919,7 +1919,7 @@ package body Sem_Ch13 is
|
|||
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
|
||||
|
|
@ -2070,6 +2070,7 @@ package body Sem_Ch13 is
|
|||
------------------------------
|
||||
|
||||
procedure Check_Indexing_Functions is
|
||||
Indexing_Found : Boolean;
|
||||
|
||||
procedure Check_One_Function (Subp : Entity_Id);
|
||||
-- Check one possible interpretation
|
||||
|
|
@ -2085,29 +2086,38 @@ package body Sem_Ch13 is
|
|||
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;
|
||||
|
||||
|
|
@ -2129,6 +2139,7 @@ package body Sem_Ch13 is
|
|||
It : Interp;
|
||||
|
||||
begin
|
||||
Indexing_Found := False;
|
||||
Get_First_Interp (Expr, I, It);
|
||||
while Present (It.Nam) loop
|
||||
|
||||
|
|
@ -2142,6 +2153,11 @@ package body Sem_Ch13 is
|
|||
|
||||
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;
|
||||
|
|
|
|||
|
|
@ -500,10 +500,6 @@ package body Sem_Ch6 is
|
|||
end if;
|
||||
|
||||
Analyze_Call (N);
|
||||
|
||||
-- Propagate the dimensions from the returned type, if necessary
|
||||
|
||||
Analyze_Dimension (N);
|
||||
end Analyze_Function_Call;
|
||||
|
||||
-----------------------------
|
||||
|
|
|
|||
|
|
@ -1507,151 +1507,160 @@ package body Sem_Dim is
|
|||
-- 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
|
||||
-- Check the dimensions of the actuals, if any
|
||||
|
||||
-- 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 not Is_Empty_List (Actuals) then
|
||||
-- Special processing for elementary functions
|
||||
|
||||
if Nkind (N) = N_Function_Call then
|
||||
Elementary_Function_Calls : declare
|
||||
Dims_Of_Call : Dimension_Type;
|
||||
Ent : Entity_Id := Nam;
|
||||
-- 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;
|
||||
-- Given Sub_Id, the original subprogram entity, return True if
|
||||
-- call is to an elementary function
|
||||
-- (see Ada.Numerics.Generic_Elementary_Functions).
|
||||
if Nkind (N) = N_Function_Call then
|
||||
Elementary_Function_Calls : declare
|
||||
Dims_Of_Call : Dimension_Type;
|
||||
Ent : Entity_Id := Nam;
|
||||
|
||||
-----------------------------------
|
||||
-- Is_Elementary_Function_Entity --
|
||||
-----------------------------------
|
||||
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).
|
||||
|
||||
function Is_Elementary_Function_Entity
|
||||
(Sub_Id : Entity_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Sub_Id);
|
||||
-----------------------------------
|
||||
-- Is_Elementary_Function_Entity --
|
||||
-----------------------------------
|
||||
|
||||
function Is_Elementary_Function_Entity
|
||||
(Sub_Id : Entity_Id) return Boolean
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Sub_Id);
|
||||
|
||||
begin
|
||||
-- Is function entity in
|
||||
-- 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;
|
||||
|
||||
-- Start of processing for Elementary_Function_Calls
|
||||
|
||||
begin
|
||||
-- Is function entity in
|
||||
-- Ada.Numerics.Generic_Elementary_Functions?
|
||||
-- Get the original subprogram entity following the renaming
|
||||
-- chain.
|
||||
|
||||
return
|
||||
Loc > No_Location
|
||||
and then
|
||||
Is_RTU
|
||||
(Cunit_Entity (Get_Source_Unit (Loc)),
|
||||
Ada_Numerics_Generic_Elementary_Functions);
|
||||
end Is_Elementary_Function_Entity;
|
||||
|
||||
-- Start of processing for Elementary_Function_Calls
|
||||
|
||||
begin
|
||||
-- Get the original subprogram entity following the renaming chain
|
||||
|
||||
if Present (Alias (Ent)) then
|
||||
Ent := Alias (Ent);
|
||||
end if;
|
||||
|
||||
-- Check the call is an Elementary function call
|
||||
|
||||
if Is_Elementary_Function_Entity (Ent) then
|
||||
|
||||
-- Sqrt function call case
|
||||
|
||||
if Chars (Ent) = Name_Sqrt then
|
||||
Dims_Of_Call := Dimensions_Of (First_Actual (N));
|
||||
|
||||
-- Eavluates the resulting dimensions (i.e. half the
|
||||
-- dimensions of the actual).
|
||||
|
||||
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;
|
||||
|
||||
Set_Dimensions (N, Dims_Of_Call);
|
||||
end if;
|
||||
|
||||
-- All other elementary functions case. Note that every actual
|
||||
-- here should be dimensionless.
|
||||
|
||||
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;
|
||||
|
||||
Next_Actual (Actual);
|
||||
end loop;
|
||||
if Present (Alias (Ent)) then
|
||||
Ent := Alias (Ent);
|
||||
end if;
|
||||
|
||||
-- Nothing more to do for elementary functions
|
||||
-- Check the call is an Elementary function call
|
||||
|
||||
return;
|
||||
end if;
|
||||
end Elementary_Function_Calls;
|
||||
end if;
|
||||
if Is_Elementary_Function_Entity (Ent) then
|
||||
-- Sqrt function call case
|
||||
|
||||
-- General case. Check, for each parameter, the dimensions of the actual
|
||||
-- and its corresponding formal match. Otherwise, complain.
|
||||
if Chars (Ent) = Name_Sqrt then
|
||||
Dims_Of_Call := Dimensions_Of (First_Actual (N));
|
||||
|
||||
Actual := First_Actual (N);
|
||||
Formal := First_Formal (Nam);
|
||||
-- Evaluates the resulting dimensions (i.e. half the
|
||||
-- dimensions of the actual).
|
||||
|
||||
while Present (Formal) loop
|
||||
Formal_Typ := Etype (Formal);
|
||||
Dims_Of_Formal := Dimensions_Of (Formal_Typ);
|
||||
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 the formal is not dimensionless, check dimensions of formal and
|
||||
-- actual match. Otherwise, complain.
|
||||
Set_Dimensions (N, Dims_Of_Call);
|
||||
end if;
|
||||
|
||||
if Exists (Dims_Of_Formal)
|
||||
and then Dimensions_Of (Actual) /= Dims_Of_Formal
|
||||
then
|
||||
-- Check if an 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", N, Name (N));
|
||||
Error_Detected := True;
|
||||
end if;
|
||||
else
|
||||
Actual := First_Actual (N);
|
||||
while Present (Actual) loop
|
||||
if Exists (Dimensions_Of (Actual)) then
|
||||
|
||||
Error_Msg_N ("\expected dimension " &
|
||||
Dimensions_Msg_Of (Formal_Typ) & ", found " &
|
||||
Dimensions_Msg_Of (Actual),
|
||||
Actual);
|
||||
-- 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;
|
||||
|
||||
Next_Actual (Actual);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Nothing more to do for elementary functions
|
||||
|
||||
return;
|
||||
end if;
|
||||
end Elementary_Function_Calls;
|
||||
end if;
|
||||
|
||||
Next_Actual (Actual);
|
||||
Next_Formal (Formal);
|
||||
end loop;
|
||||
-- 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);
|
||||
|
||||
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 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;
|
||||
|
||||
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;
|
||||
|
||||
-- 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;
|
||||
|
||||
---------------------------------------------
|
||||
|
|
|
|||
|
|
@ -236,9 +236,9 @@ package body Switch.M is
|
|||
-- One-letter switches
|
||||
|
||||
when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' |
|
||||
'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'o' |
|
||||
'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | 't' |
|
||||
'u' | 'U' | 'v' | 'x' | 'X' | 'Z' =>
|
||||
'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'p' |
|
||||
'P' | 'q' | 'Q' | 'r' | 's' | 'S' | 't' | 'u' |
|
||||
'U' | 'v' | 'x' | 'X' | 'Z' =>
|
||||
Storing (First_Stored) := C;
|
||||
Add_Switch_Component
|
||||
(Storing (Storing'First .. First_Stored));
|
||||
|
|
@ -441,6 +441,32 @@ package body Switch.M is
|
|||
Add_Switch_Component
|
||||
(Storing (Storing'First .. Last_Stored));
|
||||
|
||||
-- -gnato may be -gnatox or -gnatoxx, with x=0/1/2/3
|
||||
|
||||
when 'o' =>
|
||||
Last_Stored := First_Stored;
|
||||
Storing (Last_Stored) := 'o';
|
||||
Ptr := Ptr + 1;
|
||||
|
||||
if Ptr <= Max
|
||||
and then Switch_Chars (Ptr) in '0' .. '3'
|
||||
then
|
||||
Last_Stored := Last_Stored + 1;
|
||||
Storing (Last_Stored) := Switch_Chars (Ptr);
|
||||
Ptr := Ptr + 1;
|
||||
|
||||
if Ptr <= Max
|
||||
and then Switch_Chars (Ptr) in '0' .. '3'
|
||||
then
|
||||
Last_Stored := Last_Stored + 1;
|
||||
Storing (Last_Stored) := Switch_Chars (Ptr);
|
||||
Ptr := Ptr + 1;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Add_Switch_Component
|
||||
(Storing (Storing'First .. Last_Stored));
|
||||
|
||||
-- -gnatR may be followed by '0', '1', '2' or '3',
|
||||
-- then by 's'
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue