Skip to content

R
riscv-gcc-1
Commit 9a7e930f by Arnaud Charlet
Options

[multiple changes] 

2011-12-22  Vincent Pucci  <pucci@adacore.com>

	* sem_dim.adb: Addressed all ??? comments. Replacement of warnings by
	errors using continuation marks.
	(Error_Dim_Msg_For_?): Renaming of Error_Dim_For_?.

2011-12-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, sem_ch3.ads, sem_prag.adb: Minor code clean up.

From-SVN: r182616
parent 868df137
Showing with 167 additions and 149 deletions
gcc/ada/ChangeLog
2011-12-22 Vincent Pucci <pucci@adacore.com>
* sem_dim.adb: Addressed all ??? comments. Replacement of warnings by
errors using continuation marks.
(Error_Dim_Msg_For_?): Renaming of Error_Dim_For_?.
2011-12-22 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_ch3.ads, sem_prag.adb: Minor code clean up.
2011-12-21 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> 2011-12-21 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* s-oscons-tmplt.c [__alpha__ && __osf__] (_XOPEN_SOURCE): Define. * s-oscons-tmplt.c [__alpha__ && __osf__] (_XOPEN_SOURCE): Define.
......
gcc/ada/sem_ch3.adb
...@@ -9640,37 +9640,39 @@ package body Sem_Ch3 is ...@@ -9640,37 +9640,39 @@ package body Sem_Ch3 is
end loop; end loop;
end Check_Completion; end Check_Completion;
-------------------- ------------------------------------
-- Check_CPP_Type -- -- Check_CPP_Type_Has_No_Defaults --
-------------------- ------------------------------------
procedure Check_CPP_Type (T : Entity_Id) is procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id) is
Tdef : constant Node_Id := Type_Definition (Declaration_Node (T)); Tdef : constant Node_Id := Type_Definition (Declaration_Node (T));
Clist : Node_Id; Clist : Node_Id;
Comp : Node_Id; Comp : Node_Id;
begin begin
-- Obtain the component list
if Nkind (Tdef) = N_Record_Definition then if Nkind (Tdef) = N_Record_Definition then
Clist := Component_List (Tdef); Clist := Component_List (Tdef);
else pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
else
pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
Clist := Component_List (Record_Extension_Part (Tdef)); Clist := Component_List (Record_Extension_Part (Tdef));
end if; end if;
-- Check all components to ensure no default expressions
if Present (Clist) then if Present (Clist) then
Comp := First (Component_Items (Clist)); Comp := First (Component_Items (Clist));
while Present (Comp) loop while Present (Comp) loop
if Present (Expression (Comp)) then if Present (Expression (Comp)) then
Error_Msg_N Error_Msg_N
("component of imported 'C'P'P type cannot have" & ("component of imported 'C'P'P type cannot have "
" default expression", Expression (Comp)); & "default expression", Expression (Comp));
end if; end if;
Next (Comp); Next (Comp);
end loop; end loop;
end if; end if;
end Check_CPP_Type; end Check_CPP_Type_Has_No_Defaults;
---------------------------- ----------------------------
-- Check_Delta_Expression -- -- Check_Delta_Expression --
...@@ -18130,7 +18132,7 @@ package body Sem_Ch3 is ...@@ -18130,7 +18132,7 @@ package body Sem_Ch3 is
-- Check that components of imported CPP types do not have default -- Check that components of imported CPP types do not have default
-- expressions. -- expressions.
Check_CPP_Type (Full_T); Check_CPP_Type_Has_No_Defaults (Full_T);
end if; end if;
-- If the private view has user specified stream attributes, then so has -- If the private view has user specified stream attributes, then so has
......
gcc/ada/sem_ch3.ads
...@@ -115,7 +115,7 @@ package Sem_Ch3 is ...@@ -115,7 +115,7 @@ package Sem_Ch3 is
-- and errors are posted on that node, rather than on the declarations that -- and errors are posted on that node, rather than on the declarations that
-- require completion in the package declaration. -- require completion in the package declaration.
procedure Check_CPP_Type (T : Entity_Id); procedure Check_CPP_Type_Has_No_Defaults (T : Entity_Id);
-- Check that components of imported CPP type T do not have default -- Check that components of imported CPP type T do not have default
-- expressions because the constructor (if any) is on the C++ side. -- expressions because the constructor (if any) is on the C++ side.
......
gcc/ada/sem_dim.adb
...@@ -258,7 +258,7 @@ package body Sem_Dim is ...@@ -258,7 +258,7 @@ package body Sem_Dim is
-- 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
-- (if expression is present) match. Note that when the expression is -- (if expression is present) match. Note that when the expression is
-- a literal, no warning is returned. This special case allows object -- a literal, no error is returned. This special case allows object
-- declaration such as: m : constant Length := 1.0; -- declaration such as: m : constant Length := 1.0;
procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id); procedure Analyze_Dimension_Object_Renaming_Declaration (N : Node_Id);
...@@ -274,7 +274,7 @@ package body Sem_Dim is ...@@ -274,7 +274,7 @@ package body Sem_Dim is
-- Subroutine of Analyze_Dimension for subtype declaration. Propagate the -- Subroutine of Analyze_Dimension for subtype declaration. Propagate the
-- dimensions from the parent type to the identifier of N. Note that if -- dimensions from the parent type to the identifier of N. Note that if
-- both the identifier and the parent type of N are not dimensionless, -- both the identifier and the parent type of N are not dimensionless,
-- return an error message. -- return an error.
procedure Analyze_Dimension_Unary_Op (N : Node_Id); procedure Analyze_Dimension_Unary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
...@@ -1035,26 +1035,33 @@ package body Sem_Dim is ...@@ -1035,26 +1035,33 @@ package body Sem_Dim is
Rhs : constant Node_Id := Expression (N); Rhs : constant Node_Id := Expression (N);
Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs); Dims_Of_Rhs : constant Dimension_Type := Dimensions_Of (Rhs);
procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id); procedure Error_Dim_Msg_For_Assignment_Statement
-- Error using Error_Msg_N at node N. Output in the error message the (N : Node_Id;
-- dimensions of left and right hand sides. Lhs : Node_Id;
Rhs : Node_Id);
---------------------------------------- -- Error using Error_Msg_N at node N. Output the dimensions of left
-- Error_Dim_For_Assignment_Statement -- -- and right hand sides.
----------------------------------------
--------------------------------------------
procedure Error_Dim_For_Assignment_Statement (N, Lhs, Rhs : Node_Id) is -- Error_Dim_Msg_For_Assignment_Statement --
--------------------------------------------
procedure Error_Dim_Msg_For_Assignment_Statement
(N : Node_Id;
Lhs : Node_Id;
Rhs : Node_Id)
is
begin begin
Error_Msg_N ("?dimensions mismatch in assignment", N); Error_Msg_N ("dimensions mismatch in assignment", N);
Error_Msg_N ("?left-hand side " & Dimensions_Msg_Of (Lhs), N); Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N);
Error_Msg_N ("?right-hand side " & Dimensions_Msg_Of (Rhs), N); Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N);
end Error_Dim_For_Assignment_Statement; end Error_Dim_Msg_For_Assignment_Statement;
-- Start of processing for Analyze_Dimension_Assignment -- Start of processing for Analyze_Dimension_Assignment
begin begin
if Dims_Of_Lhs /= Dims_Of_Rhs then if Dims_Of_Lhs /= Dims_Of_Rhs then
Error_Dim_For_Assignment_Statement (N, Lhs, Rhs); Error_Dim_Msg_For_Assignment_Statement (N, Lhs, Rhs);
end if; end if;
end Analyze_Dimension_Assignment_Statement; end Analyze_Dimension_Assignment_Statement;
...@@ -1068,23 +1075,23 @@ package body Sem_Dim is ...@@ -1068,23 +1075,23 @@ 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);
procedure Error_Dim_For_Binary_Op (N, L, R : Node_Id); procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id);
-- Error using Error_Msg_N at node N -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the
-- Output in the error message the dimensions of both operands. -- dimensions of both operands.
----------------------------- ---------------------------------
-- Error_Dim_For_Binary_Op -- -- Error_Dim_Msg_For_Binary_Op --
----------------------------- ---------------------------------
procedure Error_Dim_For_Binary_Op (N, L, R : Node_Id) is procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id) is
begin begin
Error_Msg_NE ("?both operands for operation& must have same " & Error_Msg_NE ("both operands for operation& must have same " &
"dimensions", "dimensions",
N, N,
Entity (N)); Entity (N));
Error_Msg_N ("?left operand " & Dimensions_Msg_Of (L), N); Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N);
Error_Msg_N ("?right operand " & Dimensions_Msg_Of (R), N); Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N);
end Error_Dim_For_Binary_Op; end Error_Dim_Msg_For_Binary_Op;
-- Start of processing for Analyze_Dimension_Binary_Op -- Start of processing for Analyze_Dimension_Binary_Op
...@@ -1110,7 +1117,7 @@ package body Sem_Dim is ...@@ -1110,7 +1117,7 @@ package body Sem_Dim is
-- Check both operands have same dimension -- Check both operands have same dimension
if Dims_Of_L /= Dims_Of_R then if Dims_Of_L /= Dims_Of_R then
Error_Dim_For_Binary_Op (N, L, R); Error_Dim_Msg_For_Binary_Op (N, L, R);
else else
-- Check both operands are not dimensionless -- Check both operands are not dimensionless
...@@ -1216,7 +1223,7 @@ package body Sem_Dim is ...@@ -1216,7 +1223,7 @@ package body Sem_Dim is
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_For_Binary_Op (N, L, R); Error_Dim_Msg_For_Binary_Op (N, L, R);
end if; end if;
end if; end if;
...@@ -1239,26 +1246,26 @@ package body Sem_Dim is ...@@ -1239,26 +1246,26 @@ package body Sem_Dim is
Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
Dims_Of_Expr : Dimension_Type; Dims_Of_Expr : Dimension_Type;
procedure Error_Dim_For_Component_Declaration procedure Error_Dim_Msg_For_Component_Declaration
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Error using Error_Msg_N at node N. Output in the error message the -- Error using Error_Msg_N at node N. Output the dimensions of the
-- dimensions of the type Etyp and the expression Expr of N. -- type Etyp and the expression Expr of N.
----------------------------------------- ---------------------------------------------
-- Error_Dim_For_Component_Declaration -- -- Error_Dim_Msg_For_Component_Declaration --
----------------------------------------- ---------------------------------------------
procedure Error_Dim_For_Component_Declaration procedure Error_Dim_Msg_For_Component_Declaration
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id) is Expr : Node_Id) is
begin begin
Error_Msg_N ("?dimensions mismatch in component declaration", N); Error_Msg_N ("dimensions mismatch in component declaration", N);
Error_Msg_N ("\?component type " & Dimensions_Msg_Of (Etyp), N); Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N);
Error_Msg_N ("\?component expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Component_Declaration; end Error_Dim_Msg_For_Component_Declaration;
-- Start of processing for Analyze_Dimension_Component_Declaration -- Start of processing for Analyze_Dimension_Component_Declaration
...@@ -1270,7 +1277,7 @@ package body Sem_Dim is ...@@ -1270,7 +1277,7 @@ package body Sem_Dim is
-- dimension of the type mismatch. -- dimension of the type mismatch.
if Dims_Of_Etyp /= Dims_Of_Expr then if Dims_Of_Etyp /= Dims_Of_Expr then
Error_Dim_For_Component_Declaration (N, Etyp, Expr); Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr);
end if; end if;
-- Removal of dimensions in expression -- Removal of dimensions in expression
...@@ -1296,31 +1303,31 @@ package body Sem_Dim is ...@@ -1296,31 +1303,31 @@ package body Sem_Dim is
Return_Obj_Decl : Node_Id; Return_Obj_Decl : Node_Id;
Return_Obj_Id : Entity_Id; Return_Obj_Id : Entity_Id;
procedure Error_Dim_For_Extended_Return_Statement procedure Error_Dim_Msg_For_Extended_Return_Statement
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Return_Obj_Id : Entity_Id); Return_Obj_Id : Entity_Id);
-- Warning using Error_Msg_N at node N. Output in the error message the -- Error using Error_Msg_N at node N. Output the dimensions of the
-- dimensions of the returned type Return_Etyp and the returned object -- returned type Return_Etyp and the returned object Return_Obj_Id of N.
-- Return_Obj_Id of N.
--------------------------------------------- -------------------------------------------------
-- Error_Dim_For_Extended_Return_Statement -- -- Error_Dim_Msg_For_Extended_Return_Statement --
--------------------------------------------- -------------------------------------------------
procedure Error_Dim_For_Extended_Return_Statement procedure Error_Dim_Msg_For_Extended_Return_Statement
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Return_Obj_Id : Entity_Id) Return_Obj_Id : Entity_Id)
is is
begin begin
Error_Msg_N ("?dimensions mismatch in extended return statement", N); Error_Msg_N ("dimensions mismatch in extended return statement", N);
Error_Msg_N ("?returned type " & Dimensions_Msg_Of (Return_Etyp), N); Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
Error_Msg_N ("?returned object " & Dimensions_Msg_Of (Return_Obj_Id), Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id),
N); N);
end Error_Dim_For_Extended_Return_Statement; end Error_Dim_Msg_For_Extended_Return_Statement;
-- Start of processing for Analyze_Dimension_Extended_Return_Statement -- Start of processing for Analyze_Dimension_Extended_Return_Statement
begin begin
if Present (Return_Obj_Decls) then if Present (Return_Obj_Decls) then
Return_Obj_Decl := First (Return_Obj_Decls); Return_Obj_Decl := First (Return_Obj_Decls);
...@@ -1332,7 +1339,7 @@ package body Sem_Dim is ...@@ -1332,7 +1339,7 @@ package body Sem_Dim is
Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id); Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id);
if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then
Error_Dim_For_Extended_Return_Statement Error_Dim_Msg_For_Extended_Return_Statement
(N, Return_Etyp, Return_Obj_Id); (N, Return_Etyp, Return_Obj_Id);
return; return;
end if; end if;
...@@ -1355,7 +1362,7 @@ package body Sem_Dim is ...@@ -1355,7 +1362,7 @@ package body Sem_Dim is
Dims_Of_Actual : Dimension_Type; Dims_Of_Actual : Dimension_Type;
Dims_Of_Call : Dimension_Type; Dims_Of_Call : Dimension_Type;
function Is_Elementary_Function_Call (N : Node_Id) return Boolean; function Is_Elementary_Function_Call return Boolean;
-- Return True if the call is a call of an elementary function (see -- Return True if the call is a call of an elementary function (see
-- Ada.Numerics.Generic_Elementary_Functions). -- Ada.Numerics.Generic_Elementary_Functions).
...@@ -1363,13 +1370,11 @@ package body Sem_Dim is ...@@ -1363,13 +1370,11 @@ package body Sem_Dim is
-- Is_Elementary_Function_Call -- -- Is_Elementary_Function_Call --
--------------------------------- ---------------------------------
function Is_Elementary_Function_Call (N : Node_Id) return Boolean is function Is_Elementary_Function_Call return Boolean is
Ent : Entity_Id; Ent : Entity_Id;
begin begin
-- Note that the node must come from source (why not???) if Is_Entity_Name (Name_Call) then
if Comes_From_Source (N) and then Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call); Ent := Entity (Name_Call);
-- Check the procedure is defined in an instantiation of a generic -- Check the procedure is defined in an instantiation of a generic
...@@ -1395,7 +1400,7 @@ package body Sem_Dim is ...@@ -1395,7 +1400,7 @@ package body Sem_Dim is
begin begin
-- Elementary function case -- Elementary function case
if Is_Elementary_Function_Call (N) then if Is_Elementary_Function_Call then
-- Sqrt function call case -- Sqrt function call case
...@@ -1421,11 +1426,12 @@ package body Sem_Dim is ...@@ -1421,11 +1426,12 @@ package body Sem_Dim is
Dims_Of_Actual := Dimensions_Of (Actual); Dims_Of_Actual := Dimensions_Of (Actual);
if Exists (Dims_Of_Actual) then if Exists (Dims_Of_Actual) then
Error_Msg_NE Error_Msg_NE ("parameter should be dimensionless for " &
("?parameter should be dimensionless for elementary " "elementary function&",
& "function&", Actual, Name_Call); Actual,
Error_Msg_N Name_Call);
("?parameter " & Dimensions_Msg_Of (Actual), Actual); Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
Actual);
end if; end if;
Next (Actual); Next (Actual);
...@@ -1446,7 +1452,6 @@ package body Sem_Dim is ...@@ -1446,7 +1452,6 @@ package body Sem_Dim is
procedure Analyze_Dimension_Has_Etype (N : Node_Id) is procedure Analyze_Dimension_Has_Etype (N : Node_Id) is
Etyp : constant Entity_Id := Etype (N); Etyp : constant Entity_Id := Etype (N);
Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); Dims_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
N_Kind : constant Node_Kind := Nkind (N);
begin begin
-- Propagation of the dimensions from the type -- Propagation of the dimensions from the type
...@@ -1457,31 +1462,35 @@ package body Sem_Dim is ...@@ -1457,31 +1462,35 @@ package body Sem_Dim is
-- Removal of dimensions in expression -- Removal of dimensions in expression
-- Wouldn't a case statement be clearer here??? case Nkind (N) is
if Nkind_In (N_Kind, N_Attribute_Reference, N_Indexed_Component) then when N_Attribute_Reference |
declare N_Indexed_Component =>
Expr : Node_Id; declare
Exprs : constant List_Id := Expressions (N); Expr : Node_Id;
begin Exprs : constant List_Id := Expressions (N);
if Present (Exprs) then
Expr := First (Exprs);
while Present (Expr) loop
Remove_Dimensions (Expr);
Next (Expr);
end loop;
end if;
end;
elsif Nkind_In (N_Kind, N_Qualified_Expression, begin
N_Type_Conversion, if Present (Exprs) then
N_Unchecked_Type_Conversion) Expr := First (Exprs);
then while Present (Expr) loop
Remove_Dimensions (Expression (N)); Remove_Dimensions (Expr);
Next (Expr);
end loop;
end if;
end;
elsif N_Kind = N_Selected_Component then when N_Qualified_Expression |
Remove_Dimensions (Selector_Name (N)); N_Type_Conversion |
end if; N_Unchecked_Type_Conversion =>
Remove_Dimensions (Expression (N));
when N_Selected_Component =>
Remove_Dimensions (Selector_Name (N));
when others => null;
end case;
end Analyze_Dimension_Has_Etype; end Analyze_Dimension_Has_Etype;
------------------------------------------ ------------------------------------------
...@@ -1495,26 +1504,26 @@ package body Sem_Dim is ...@@ -1495,26 +1504,26 @@ package body Sem_Dim is
Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp); Dim_Of_Etyp : constant Dimension_Type := Dimensions_Of (Etyp);
Dim_Of_Expr : Dimension_Type; Dim_Of_Expr : Dimension_Type;
procedure Error_Dim_For_Object_Declaration procedure Error_Dim_Msg_For_Object_Declaration
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Warnings using Error_Msg_N at node N. Output in the error message the -- Error using Error_Msg_N at node N. Output the dimensions of the
-- dimensions of the type Etyp and the ??? -- type Etyp and of the expression Expr.
-------------------------------------- ------------------------------------------
-- Error_Dim_For_Object_Declaration -- -- Error_Dim_Msg_For_Object_Declaration --
-------------------------------------- ------------------------------------------
procedure Error_Dim_For_Object_Declaration procedure Error_Dim_Msg_For_Object_Declaration
(N : Node_Id; (N : Node_Id;
Etyp : Entity_Id; Etyp : Entity_Id;
Expr : Node_Id) is Expr : Node_Id) is
begin begin
Error_Msg_N ("?dimensions mismatch in object declaration", N); Error_Msg_N ("dimensions mismatch in object declaration", N);
Error_Msg_N ("\?object type " & Dimensions_Msg_Of (Etyp), N); Error_Msg_N ("\object type " & Dimensions_Msg_Of (Etyp), N);
Error_Msg_N ("\?object expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\object expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Object_Declaration; end Error_Dim_Msg_For_Object_Declaration;
-- Start of processing for Analyze_Dimension_Object_Declaration -- Start of processing for Analyze_Dimension_Object_Declaration
...@@ -1532,7 +1541,7 @@ package body Sem_Dim is ...@@ -1532,7 +1541,7 @@ package body Sem_Dim is
N_Integer_Literal) N_Integer_Literal)
and then Dim_Of_Expr /= Dim_Of_Etyp and then Dim_Of_Expr /= Dim_Of_Etyp
then then
Error_Dim_For_Object_Declaration (N, Etyp, Expr); Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr);
end if; end if;
-- Removal of dimensions in expression -- Removal of dimensions in expression
...@@ -1549,34 +1558,34 @@ package body Sem_Dim is ...@@ -1549,34 +1558,34 @@ package body Sem_Dim is
Renamed_Name : constant Node_Id := Name (N); Renamed_Name : constant Node_Id := Name (N);
Sub_Mark : constant Node_Id := Subtype_Mark (N); Sub_Mark : constant Node_Id := Subtype_Mark (N);
procedure Error_Dim_For_Object_Renaming_Declaration procedure Error_Dim_Msg_For_Object_Renaming_Declaration
(N : Node_Id; (N : Node_Id;
Sub_Mark : Node_Id; Sub_Mark : Node_Id;
Renamed_Name : Node_Id); Renamed_Name : Node_Id);
-- Error using Error_Msg_N at node N. Output in the error message the -- Error using Error_Msg_N at node N. Output the dimensions of
-- dimensions of Sub_Mark and of Renamed_Name. -- Sub_Mark and of Renamed_Name.
----------------------------------------------- ---------------------------------------------------
-- Error_Dim_For_Object_Renaming_Declaration -- -- Error_Dim_Msg_For_Object_Renaming_Declaration --
----------------------------------------------- ---------------------------------------------------
procedure Error_Dim_For_Object_Renaming_Declaration procedure Error_Dim_Msg_For_Object_Renaming_Declaration
(N : Node_Id; (N : Node_Id;
Sub_Mark : Node_Id; Sub_Mark : Node_Id;
Renamed_Name : Node_Id) is Renamed_Name : Node_Id) is
begin begin
Error_Msg_N ("?dimensions mismatch in object renaming declaration", Error_Msg_N ("dimensions mismatch in object renaming declaration",
N); N);
Error_Msg_N ("?type " & Dimensions_Msg_Of (Sub_Mark), N); Error_Msg_N ("\type " & Dimensions_Msg_Of (Sub_Mark), N);
Error_Msg_N ("?renamed object " & Dimensions_Msg_Of (Renamed_Name), Error_Msg_N ("\renamed object " & Dimensions_Msg_Of (Renamed_Name),
N); N);
end Error_Dim_For_Object_Renaming_Declaration; end Error_Dim_Msg_For_Object_Renaming_Declaration;
-- Start of processing for Analyze_Dimension_Object_Renaming_Declaration -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration
begin begin
if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then if Dimensions_Of (Renamed_Name) /= Dimensions_Of (Sub_Mark) then
Error_Dim_For_Object_Renaming_Declaration Error_Dim_Msg_For_Object_Renaming_Declaration
(N, Sub_Mark, Renamed_Name); (N, Sub_Mark, Renamed_Name);
end if; end if;
end Analyze_Dimension_Object_Renaming_Declaration; end Analyze_Dimension_Object_Renaming_Declaration;
...@@ -1594,34 +1603,33 @@ package body Sem_Dim is ...@@ -1594,34 +1603,33 @@ package body Sem_Dim is
Dims_Of_Return_Etyp : constant Dimension_Type := Dims_Of_Return_Etyp : constant Dimension_Type :=
Dimensions_Of (Return_Etyp); Dimensions_Of (Return_Etyp);
procedure Error_Dim_For_Simple_Return_Statement procedure Error_Dim_Msg_For_Simple_Return_Statement
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Expr : Node_Id); Expr : Node_Id);
-- Error using Error_Msg_N at node N. Output in the error message -- Error using Error_Msg_N at node N. Output the dimensions of the
-- the dimensions of the returned type Return_Etyp and the returned -- returned type Return_Etyp and the returned expression Expr of N.
-- expression Expr of N.
------------------------------------------- -----------------------------------------------
-- Error_Dim_For_Simple_Return_Statement -- -- Error_Dim_Msg_For_Simple_Return_Statement --
------------------------------------------- -----------------------------------------------
procedure Error_Dim_For_Simple_Return_Statement procedure Error_Dim_Msg_For_Simple_Return_Statement
(N : Node_Id; (N : Node_Id;
Return_Etyp : Entity_Id; Return_Etyp : Entity_Id;
Expr : Node_Id) Expr : Node_Id)
is is
begin begin
Error_Msg_N ("?dimensions mismatch in return statement", N); Error_Msg_N ("dimensions mismatch in return statement", N);
Error_Msg_N ("\?returned type " & Dimensions_Msg_Of (Return_Etyp), N); Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N);
Error_Msg_N ("\?returned expression " & Dimensions_Msg_Of (Expr), N); Error_Msg_N ("\returned expression " & Dimensions_Msg_Of (Expr), N);
end Error_Dim_For_Simple_Return_Statement; end Error_Dim_Msg_For_Simple_Return_Statement;
-- Start of processing for Analyze_Dimension_Simple_Return_Statement -- Start of processing for Analyze_Dimension_Simple_Return_Statement
begin begin
if Dims_Of_Return_Etyp /= Dims_Of_Expr then if Dims_Of_Return_Etyp /= Dims_Of_Expr then
Error_Dim_For_Simple_Return_Statement (N, Return_Etyp, Expr); Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
Remove_Dimensions (Expr); Remove_Dimensions (Expr);
end if; end if;
end Analyze_Dimension_Simple_Return_Statement; end Analyze_Dimension_Simple_Return_Statement;
...@@ -1649,7 +1657,7 @@ package body Sem_Dim is ...@@ -1649,7 +1657,7 @@ package body Sem_Dim is
-- it cannot inherit a dimension from its subtype. -- it cannot inherit a dimension from its subtype.
if Exists (Dims_Of_Id) then if Exists (Dims_Of_Id) then
Error_Msg_N ("?subtype& already" & Dimensions_Msg_Of (Id), N); Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id), N);
else else
Set_Dimensions (Id, Dims_Of_Etyp); Set_Dimensions (Id, Dims_Of_Etyp);
Set_Symbol (Id, Symbol_Of (Etyp)); Set_Symbol (Id, Symbol_Of (Etyp));
...@@ -1698,7 +1706,7 @@ package body Sem_Dim is ...@@ -1698,7 +1706,7 @@ package body Sem_Dim is
-- RATIONAL ::= [-] NUMERAL [/ NUMERAL] -- RATIONAL ::= [-] NUMERAL [/ NUMERAL]
-- A rational number is a number that can be expressed as the quotient or -- A rational number is a number that can be expressed as the quotient or
-- fraction a/b of two integers, where b is non-zero. -- fraction a/b of two integers, where b is non-zero positive.
function Create_Rational_From function Create_Rational_From
(Expr : Node_Id; (Expr : Node_Id;
...@@ -1889,7 +1897,7 @@ package body Sem_Dim is ...@@ -1889,7 +1897,7 @@ package body Sem_Dim is
if Exists (Dims_Of_N) then if Exists (Dims_Of_N) then
System := System_Of (Base_Type (Etype (N))); System := System_Of (Base_Type (Etype (N)));
Add_Str_To_Name_Buffer ("has dimensions: "); Add_Str_To_Name_Buffer ("has dimensions ");
Add_Dimension_Vector_To_Buffer (Dims_Of_N, System); Add_Dimension_Vector_To_Buffer (Dims_Of_N, System);
else else
Add_Str_To_Name_Buffer ("is dimensionless"); Add_Str_To_Name_Buffer ("is dimensionless");
...@@ -1914,8 +1922,7 @@ package body Sem_Dim is ...@@ -1914,8 +1922,7 @@ package body Sem_Dim is
-- Eval_Op_Expon_For_Dimensioned_Type -- -- Eval_Op_Expon_For_Dimensioned_Type --
---------------------------------------- ----------------------------------------
-- Evaluate the expon operator for real dimensioned type. Note that the -- Evaluate the expon operator for real dimensioned type.
-- node must come from source. Why???
-- Note that if the exponent is an integer (denominator = 1) the node is -- Note that if the exponent is an integer (denominator = 1) the node is
-- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval). -- evaluated by the regular Eval_Op_Expon routine (see Sem_Eval).
...@@ -1928,9 +1935,7 @@ package body Sem_Dim is ...@@ -1928,9 +1935,7 @@ package body Sem_Dim is
R_Value : Rational := No_Rational; R_Value : Rational := No_Rational;
begin begin
if Comes_From_Source (N) if Is_Real_Type (Btyp) then
and then Is_Real_Type (Btyp)
then
R_Value := Create_Rational_From (R, False); R_Value := Create_Rational_From (R, False);
end if; end if;
......
gcc/ada/sem_prag.adb
...@@ -4604,11 +4604,12 @@ package body Sem_Prag is ...@@ -4604,11 +4604,12 @@ package body Sem_Prag is
elsif C = Convention_CPP elsif C = Convention_CPP
and then (Is_Record_Type (Def_Id) and then (Is_Record_Type (Def_Id)
or else Ekind (Def_Id) = E_Incomplete_Type) or else Ekind (Def_Id) = E_Incomplete_Type)
then then
if Ekind (Def_Id) = E_Incomplete_Type then if Ekind (Def_Id) = E_Incomplete_Type then
if Present (Full_View (Def_Id)) then if Present (Full_View (Def_Id)) then
Def_Id := Full_View (Def_Id); Def_Id := Full_View (Def_Id);
else else
Error_Msg_N Error_Msg_N
("cannot import 'C'P'P type before full declaration seen", ("cannot import 'C'P'P type before full declaration seen",
...@@ -4650,7 +4651,7 @@ package body Sem_Prag is ...@@ -4650,7 +4651,7 @@ package body Sem_Prag is
-- full view is analyzed (see Process_Full_View). -- full view is analyzed (see Process_Full_View).
if not Is_Private_Type (Def_Id) then if not Is_Private_Type (Def_Id) then
Check_CPP_Type (Def_Id); Check_CPP_Type_Has_No_Defaults (Def_Id);
end if; end if;
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
...@@ -4662,8 +4663,8 @@ package body Sem_Prag is ...@@ -4662,8 +4663,8 @@ package body Sem_Prag is
else else
Error_Pragma_Arg Error_Pragma_Arg
("second argument of pragma% must be object, subprogram" & ("second argument of pragma% must be object, subprogram "
" or incomplete type", & "or incomplete type",
Arg2); Arg2);
end if; end if;
......
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