Commit df9ad6bc by Arnaud Charlet

[multiple changes]

2015-11-12  Gary Dismukes  <dismukes@adacore.com>

	* gnat1drv.adb, opt.ads: Minor reformatting.

2015-11-12  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Analyze_Number_Declaration): Call Analyze_Dimension,
	to propagate dimension information from expression to named
	number.
	* sem_dim.ads: Documentation:  number declaration and explicit
	dereference can carry dimension information.
	* sem_dim.adb (Analyze_Dimension_Number_Declaration): New
	procedure, to propagate dimension information from expression
	of declaration to named number, whose type becomes one of the
	dimensioned base types rather than universal real.
	(Analyze_Dimension_Binary_Op):
	a) If one operand is a literal that is the value of a declared
	constant after constant-foloding, use the dimensions of the
	declared constant.
	b) If an operand is a literal that is a contant-folded expression,
	and expander is active, do not report a dimension mismatch if
	literal does not carry them, because dimension matching will
	have been checked previously.

From-SVN: r230244
parent 549cc9c2
2015-11-12 Gary Dismukes <dismukes@adacore.com>
* gnat1drv.adb, opt.ads: Minor reformatting.
2015-11-12 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Analyze_Number_Declaration): Call Analyze_Dimension,
to propagate dimension information from expression to named
number.
* sem_dim.ads: Documentation: number declaration and explicit
dereference can carry dimension information.
* sem_dim.adb (Analyze_Dimension_Number_Declaration): New
procedure, to propagate dimension information from expression
of declaration to named number, whose type becomes one of the
dimensioned base types rather than universal real.
(Analyze_Dimension_Binary_Op):
a) If one operand is a literal that is the value of a declared
constant after constant-foloding, use the dimensions of the
declared constant.
b) If an operand is a literal that is a contant-folded expression,
and expander is active, do not report a dimension mismatch if
literal does not carry them, because dimension matching will
have been checked previously.
2015-11-12 Ed Schonberg <schonberg@adacore.com> 2015-11-12 Ed Schonberg <schonberg@adacore.com>
* sem_ch8.adb (Find_Selected_Component): In a synchronized * sem_ch8.adb (Find_Selected_Component): In a synchronized
......
...@@ -155,7 +155,7 @@ procedure Gnat1drv is ...@@ -155,7 +155,7 @@ procedure Gnat1drv is
Operating_Mode := Generate_Code; Operating_Mode := Generate_Code;
-- Suppress alignment checks since we do not have access to alignment -- Suppress alignment checks since we do not have access to alignment
-- info on the target -- info on the target.
Suppress_Options.Suppress (Alignment_Check) := False; Suppress_Options.Suppress (Alignment_Check) := False;
end if; end if;
......
...@@ -200,7 +200,7 @@ package Opt is ...@@ -200,7 +200,7 @@ package Opt is
Alternate_Main_Name : String_Ptr := null; Alternate_Main_Name : String_Ptr := null;
-- GNATBIND -- GNATBIND
-- Set to non null when Bind_Alternate_Main_Name is True. This value -- Set to non-null when Bind_Alternate_Main_Name is True. This value
-- is modified as needed by Gnatbind.Scan_Bind_Arg. -- is modified as needed by Gnatbind.Scan_Bind_Arg.
ASIS_Mode : Boolean := False; ASIS_Mode : Boolean := False;
...@@ -424,7 +424,7 @@ package Opt is ...@@ -424,7 +424,7 @@ package Opt is
-- The value given to the -g parameter. The default value for -g with -- The value given to the -g parameter. The default value for -g with
-- no value is 2. If no -g is specified, defaults to 0. -- no value is 2. If no -g is specified, defaults to 0.
-- Note that the generated code should never depend on this variable, -- Note that the generated code should never depend on this variable,
-- since we want debug info to be non intrusive on the generate code. -- since we want debug info to be nonintrusive on the generate code.
Default_Exit_Status : Int := 0; Default_Exit_Status : Int := 0;
-- GNATBIND -- GNATBIND
...@@ -1317,8 +1317,8 @@ package Opt is ...@@ -1317,8 +1317,8 @@ package Opt is
Setup_Projects : Boolean := False; Setup_Projects : Boolean := False;
-- GNAT DRIVER -- GNAT DRIVER
-- Set to True for GNAT SETUP: the Project Manager creates non existing -- Set to True for GNAT SETUP: the Project Manager creates nonexistent
-- object, library and exec directories. -- object, library, and exec directories.
Shared_Libgnat : Boolean; Shared_Libgnat : Boolean;
-- GNATBIND -- GNATBIND
...@@ -1880,7 +1880,7 @@ package Opt is ...@@ -1880,7 +1880,7 @@ package Opt is
-- to date version of Ada). -- to date version of Ada).
Ada_Version_Pragma_Config : Node_Id; Ada_Version_Pragma_Config : Node_Id;
-- This will be set non empty if it is set by a configuration pragma -- This will be set nonempty if it is set by a configuration pragma
Ada_Version_Explicit_Config : Ada_Version_Type; Ada_Version_Explicit_Config : Ada_Version_Type;
-- GNAT -- GNAT
......
...@@ -3270,6 +3270,8 @@ package body Sem_Ch3 is ...@@ -3270,6 +3270,8 @@ package body Sem_Ch3 is
Rewrite (E, Make_Integer_Literal (Sloc (N), 1)); Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
Set_Etype (E, Any_Type); Set_Etype (E, Any_Type);
end if; end if;
Analyze_Dimension (N);
end Analyze_Number_Declaration; end Analyze_Number_Declaration;
-------------------------------- --------------------------------
......
...@@ -253,6 +253,11 @@ package body Sem_Dim is ...@@ -253,6 +253,11 @@ package body Sem_Dim is
-- N_Type_Conversion -- N_Type_Conversion
-- N_Unchecked_Type_Conversion -- N_Unchecked_Type_Conversion
procedure Analyze_Dimension_Number_Declaration (N : Node_Id);
-- Procedure to analyze dimension of expression in a number declaration.
-- This allows a named number to have non-trivial dimensions, while by
-- default a named number is dimensionless.
procedure Analyze_Dimension_Object_Declaration (N : Node_Id); procedure Analyze_Dimension_Object_Declaration (N : Node_Id);
-- Subroutine of Analyze_Dimension for object declaration. Check that -- Subroutine of Analyze_Dimension for object declaration. Check that
-- the dimensions of the object type and the dimensions of the expression -- the dimensions of the object type and the dimensions of the expression
...@@ -1147,6 +1152,9 @@ package body Sem_Dim is ...@@ -1147,6 +1152,9 @@ package body Sem_Dim is
N_Unchecked_Type_Conversion => N_Unchecked_Type_Conversion =>
Analyze_Dimension_Has_Etype (N); Analyze_Dimension_Has_Etype (N);
when N_Number_Declaration =>
Analyze_Dimension_Number_Declaration (N);
when N_Object_Declaration => when N_Object_Declaration =>
Analyze_Dimension_Object_Declaration (N); Analyze_Dimension_Object_Declaration (N);
...@@ -1308,10 +1316,30 @@ package body Sem_Dim is ...@@ -1308,10 +1316,30 @@ package body Sem_Dim is
procedure Analyze_Dimension_Binary_Op (N : Node_Id) is procedure Analyze_Dimension_Binary_Op (N : Node_Id) is
N_Kind : constant Node_Kind := Nkind (N); N_Kind : constant Node_Kind := Nkind (N);
function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type;
-- If the operand is a numeric literal that comes from a declared
-- constant, use the dimensions of the constant which were computed
-- from the expression of the constant declaration.
procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id); procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
-- Error using Error_Msg_NE and Error_Msg_N at node N. Output the -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
-- dimensions of both operands. -- dimensions of both operands.
---------------------------
-- Dimensions_Of_Operand --
---------------------------
function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is
begin
if Nkind (N) = N_Real_Literal
and then Present (Original_Entity (N))
then
return Dimensions_Of (Original_Entity (N));
else
return Dimensions_Of (N);
end if;
end Dimensions_Of_Operand;
--------------------------------- ---------------------------------
-- Error_Dim_Msg_For_Binary_Op -- -- Error_Dim_Msg_For_Binary_Op --
--------------------------------- ---------------------------------
...@@ -1334,10 +1362,12 @@ package body Sem_Dim is ...@@ -1334,10 +1362,12 @@ package body Sem_Dim is
then then
declare declare
L : constant Node_Id := Left_Opnd (N); L : constant Node_Id := Left_Opnd (N);
Dims_Of_L : constant Dimension_Type := Dimensions_Of (L); Dims_Of_L : constant Dimension_Type :=
Dimensions_Of_Operand (L);
L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L); L_Has_Dimensions : constant Boolean := Exists (Dims_Of_L);
R : constant Node_Id := Right_Opnd (N); R : constant Node_Id := Right_Opnd (N);
Dims_Of_R : constant Dimension_Type := Dimensions_Of (R); Dims_Of_R : constant Dimension_Type :=
Dimensions_Of_Operand (R);
R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R); R_Has_Dimensions : constant Boolean := Exists (Dims_Of_R);
Dims_Of_N : Dimension_Type := Null_Dimension; Dims_Of_N : Dimension_Type := Null_Dimension;
...@@ -1453,20 +1483,40 @@ package body Sem_Dim is ...@@ -1453,20 +1483,40 @@ package body Sem_Dim is
-- Comparison cases -- Comparison cases
-- For relational operations, only dimension checking is -- For relational operations, only dimension checking is
-- performed (no propagation). -- performed (no propagation). If one operand is the result
-- of constant folding the dimensions may have been lost
-- in a tree copy, so assume that pre-analysis has verified
-- that dimensions are correct.
elsif N_Kind in N_Op_Compare then elsif N_Kind in N_Op_Compare then
if (L_Has_Dimensions or R_Has_Dimensions) if (L_Has_Dimensions or R_Has_Dimensions)
and then Dims_Of_L /= Dims_Of_R and then Dims_Of_L /= Dims_Of_R
then then
Error_Dim_Msg_For_Binary_Op (N, L, R); if Nkind (L) = N_Real_Literal
and then not (Comes_From_Source (L))
and then Expander_Active
then
null;
elsif Nkind (R) = N_Real_Literal
and then not (Comes_From_Source (R))
and then Expander_Active
then
null;
else
Error_Dim_Msg_For_Binary_Op (N, L, R);
end if;
end if; end if;
end if; end if;
-- Removal of dimensions for each operands -- If expander is active, remove dimension information from each
-- operand, as only dimensions of result are relevant.
Remove_Dimensions (L); if Expander_Active then
Remove_Dimensions (R); Remove_Dimensions (L);
Remove_Dimensions (R);
end if;
end; end;
end if; end if;
end Analyze_Dimension_Binary_Op; end Analyze_Dimension_Binary_Op;
...@@ -1929,7 +1979,7 @@ package body Sem_Dim is ...@@ -1929,7 +1979,7 @@ package body Sem_Dim is
Check_Error_Detected; Check_Error_Detected;
return; return;
elsif Ekind (Id) = E_Constant elsif Ekind_In (Id, E_Constant, E_Named_Real)
and then Exists (Dimensions_Of (Id)) and then Exists (Dimensions_Of (Id))
then then
Set_Dimensions (N, Dimensions_Of (Id)); Set_Dimensions (N, Dimensions_Of (Id));
...@@ -1981,6 +2031,22 @@ package body Sem_Dim is ...@@ -1981,6 +2031,22 @@ package body Sem_Dim is
end Analyze_Dimension_Has_Etype; end Analyze_Dimension_Has_Etype;
------------------------------------------ ------------------------------------------
-- Analyze_Dimension_Number_Declaration --
------------------------------------------
procedure Analyze_Dimension_Number_Declaration (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
Id : constant Entity_Id := Defining_Identifier (N);
Dim_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
begin
if Exists (Dim_Of_Expr) then
Set_Dimensions (Id, Dim_Of_Expr);
Set_Etype (Id, Etype (Expr));
end if;
end Analyze_Dimension_Number_Declaration;
------------------------------------------
-- Analyze_Dimension_Object_Declaration -- -- Analyze_Dimension_Object_Declaration --
------------------------------------------ ------------------------------------------
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -116,8 +116,10 @@ package Sem_Dim is ...@@ -116,8 +116,10 @@ package Sem_Dim is
-- * compontent declaration -- * compontent declaration
-- * extended return statement -- * extended return statement
-- * expanded name -- * expanded name
-- * explicit dereference
-- * identifier -- * identifier
-- * indexed component -- * indexed component
-- * number declaration
-- * object declaration -- * object declaration
-- * object renaming declaration -- * object renaming declaration
-- * procedure call statement -- * procedure call statement
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment