Skip to content

R
riscv-gcc-1
Commit 260359e3 by Arnaud Charlet
Options

[multiple changes] 

2012-02-17  Robert Dewar  <dewar@adacore.com>

	* sem_dim.adb, sem_dim.ads, s-tasren.adb, prj.adb, prj.ads, freeze.adb,
	sem_res.adb, exp_ch4.adb, sinput.adb, sinput.ads, exp_aggr.adb,
	exp_intr.adb, s-os_lib.adb: Minor reformatting.

2012-02-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Is_Non_Overriding_Operation): Add warning if the
	old operation is abstract, the relevant type is not abstract,
	and the new subprogram fails to override.

From-SVN: r184336
parent bae868fb
Showing with 84 additions and 57 deletions
gcc/ada/ChangeLog
2012-02-17 Robert Dewar <dewar@adacore.com>
* sem_dim.adb, sem_dim.ads, s-tasren.adb, prj.adb, prj.ads, freeze.adb,
sem_res.adb, exp_ch4.adb, sinput.adb, sinput.ads, exp_aggr.adb,
exp_intr.adb, s-os_lib.adb: Minor reformatting.
2012-02-17 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Is_Non_Overriding_Operation): Add warning if the
old operation is abstract, the relevant type is not abstract,
and the new subprogram fails to override.
2012-02-15 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (Identifier_to_gnu): Move block retrieving the
......
gcc/ada/exp_aggr.adb
......@@ -5157,9 +5157,9 @@ package body Exp_Aggr is
-- Compile_Time_Known_Composite_Value --
----------------------------------------
function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean
function Compile_Time_Known_Composite_Value
(N : Node_Id) return Boolean
is
begin
-- If we have an entity name, then see if it is the name of a
-- constant and if so, test the corresponding constant value.
......@@ -5168,15 +5168,14 @@ package body Exp_Aggr is
declare
E : constant Entity_Id := Entity (N);
V : Node_Id;
begin
if Ekind (E) /= E_Constant then
return False;
else
V := Constant_Value (E);
return Present (V)
and then Compile_Time_Known_Composite_Value (V);
end if;
V := Constant_Value (E);
return Present (V)
and then Compile_Time_Known_Composite_Value (V);
end;
-- We have a value, see if it is compile time known
......
gcc/ada/exp_ch4.adb
......@@ -3572,21 +3572,20 @@ package body Exp_Ch4 is
(Etype (Pool), Name_Simple_Storage_Pool_Type))
then
declare
Alloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Allocate);
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
Alloc_Op : Entity_Id;
begin
Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
while Present (Alloc_Op) loop
if Scope (Alloc_Op) = Scope (Pool_Type)
and then Present (First_Formal (Alloc_Op))
and then Etype (First_Formal (Alloc_Op)) = Pool_Type
then
Set_Procedure_To_Call (N, Alloc_Op);
exit;
else
Alloc_Op := Homonym (Alloc_Op);
end if;
Alloc_Op := Homonym (Alloc_Op);
end loop;
end;
......
gcc/ada/exp_intr.adb
......@@ -1094,21 +1094,20 @@ package body Exp_Intr is
(Etype (Pool), Name_Simple_Storage_Pool_Type))
then
declare
Dealloc_Op : Entity_Id := Get_Name_Entity_Id (Name_Deallocate);
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
Dealloc_Op : Entity_Id;
begin
Dealloc_Op := Get_Name_Entity_Id (Name_Deallocate);
while Present (Dealloc_Op) loop
if Scope (Dealloc_Op) = Scope (Pool_Type)
and then Present (First_Formal (Dealloc_Op))
and then Etype (First_Formal (Dealloc_Op)) = Pool_Type
then
Set_Procedure_To_Call (Free_Node, Dealloc_Op);
exit;
else
Dealloc_Op := Homonym (Dealloc_Op);
end if;
Dealloc_Op := Homonym (Dealloc_Op);
end loop;
end;
......@@ -1140,8 +1139,8 @@ package body Exp_Intr is
if Is_Class_Wide_Type (Desig_T)
or else
(Is_Array_Type (Desig_T)
and then not Is_Constrained (Desig_T)
and then Is_Packed (Desig_T))
and then not Is_Constrained (Desig_T)
and then Is_Packed (Desig_T))
then
declare
Deref : constant Node_Id :=
......
gcc/ada/freeze.adb
......@@ -4114,7 +4114,6 @@ package body Freeze is
if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type))
and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
then
-- If the type is marked Has_Private_Declaration, then this is
-- a full type for a private type that was specified with the
-- pragma Simple_Storage_Pool_Type, and here we ensure that the
......@@ -4127,7 +4126,6 @@ package body Freeze is
and then not Is_Private_Type (E)
then
Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
Error_Msg_N
("pragma% can only apply to full type that is an " &
"explicitly limited type", E);
......@@ -4197,6 +4195,7 @@ package body Freeze is
end if;
if Etype (Pool_Op_Formal) /= Expected_Type then
-- If the pool type was expected for this formal, then
-- this will not be considered a candidate operation
-- for the simple pool, so we unset OK_Formal so that
......@@ -4243,8 +4242,8 @@ package body Freeze is
begin
pragma Assert
(Op_Name = Name_Allocate
or else Op_Name = Name_Deallocate
or else Op_Name = Name_Storage_Size);
or else Op_Name = Name_Deallocate
or else Op_Name = Name_Storage_Size);
Error_Msg_Name_1 := Op_Name;
......@@ -4270,7 +4269,6 @@ package body Freeze is
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter, Pool_Type,
"Pool", Is_OK);
else
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Out_Parameter, Pool_Type,
......@@ -4295,7 +4293,6 @@ package body Freeze is
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_Out_Parameter,
Address_Type, "Storage_Address", Is_OK);
elsif Op_Name = Name_Deallocate then
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
......@@ -4310,7 +4307,6 @@ package body Freeze is
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
Validate_Simple_Pool_Op_Formal
(Op, Formal, E_In_Parameter,
Stg_Cnt_Type, "Alignment", Is_OK);
......@@ -4338,6 +4334,7 @@ package body Freeze is
"storage pool type", Pool_Type);
elsif Present (Found_Op) then
-- Simple pool operations can't be abstract
if Is_Abstract_Subprogram (Found_Op) then
......@@ -4373,9 +4370,7 @@ package body Freeze is
begin
Validate_Simple_Pool_Operation (Name_Allocate);
Validate_Simple_Pool_Operation (Name_Deallocate);
Validate_Simple_Pool_Operation (Name_Storage_Size);
end Validate_Simple_Pool_Ops;
end if;
......
gcc/ada/prj.adb
......@@ -1893,6 +1893,7 @@ package body Prj is
is
Agg : Aggregated_Project_List;
Ctx : Project_Context;
begin
Action (Project, Tree, Context);
......@@ -1901,8 +1902,7 @@ package body Prj is
(In_Aggregate_Lib => True,
From_Encapsulated_Lib =>
Context.From_Encapsulated_Lib
or else
Project.Standalone_Library = Encapsulated);
or else Project.Standalone_Library = Encapsulated);
Agg := Project.Aggregated_Projects;
while Agg /= null loop
......@@ -1912,6 +1912,8 @@ package body Prj is
end if;
end Recursive_Process;
-- Start of processing for For_Project_And_Aggregated_Context
begin
Recursive_Process
(Root_Project, Root_Tree, Project_Context'(False, False));
......
gcc/ada/prj.ads
......@@ -1621,7 +1621,7 @@ package Prj is
With_State : in out State;
Include_Aggregated : Boolean := True;
Imported_First : Boolean := False);
-- As above but with an associated context
-- As for For_Every_Project_Imported but with an associated context
generic
with procedure Action
......@@ -1631,7 +1631,7 @@ package Prj is
procedure For_Project_And_Aggregated_Context
(Root_Project : Project_Id;
Root_Tree : Project_Tree_Ref);
-- As above but with an associated context
-- As for For_Project_And_Aggregated but with an associated context
function Extend_Name
(File : File_Name_Type;
......
gcc/ada/s-os_lib.adb
......@@ -1695,12 +1695,11 @@ package body System.OS_Lib is
else
Res (J) := Arg (K);
end if;
end loop;
if Quote_Needed then
-- If null terminated string, put the quote before
-- Case of null terminated string
if Res (J) = ASCII.NUL then
......@@ -1711,7 +1710,7 @@ package body System.OS_Lib is
J := J + 1;
end if;
-- Then adds the quote and the NUL character
-- Put a quote just before the null at the end
Res (J) := '"';
J := J + 1;
......
gcc/ada/s-tasren.adb
......@@ -110,8 +110,8 @@ package body System.Tasking.Rendezvous is
procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id);
-- Internal version of Complete_Rendezvous, used to implement
-- Complete_Rendezvous and Exceptional_Complete_Rendezvous.
-- Should be called holding no locks, generally with abort not yet
-- deferred.
-- Should be called holding no locks, generally with abort
-- not yet deferred.
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id);
pragma Inline (Boost_Priority);
......@@ -538,7 +538,7 @@ package body System.Tasking.Rendezvous is
Called_PO : STPE.Protection_Entries_Access;
Acceptor_Prev_Priority : Integer;
Ceiling_Violation : Boolean;
Ceiling_Violation : Boolean;
use type Ada.Exceptions.Exception_Id;
procedure Transfer_Occurrence
......
gcc/ada/sem_ch6.adb
......@@ -188,9 +188,9 @@ package body Sem_Ch6 is
New_E : Entity_Id) return Boolean;
-- Enforce the rule given in 12.3(18): a private operation in an instance
-- overrides an inherited operation only if the corresponding operation
-- was overriding in the generic. This can happen for primitive operations
-- of types derived (in the generic unit) from formal private or formal
-- derived types.
-- was overriding in the generic. This needs to be checked for primitive
-- operations of types derived (in the generic unit) from formal private
-- or formal derived types.
procedure Make_Inequality_Operator (S : Entity_Id);
-- Create the declaration for an inequality operator that is implicitly
......@@ -7844,6 +7844,22 @@ package body Sem_Ch6 is
-- If no match found, then the new subprogram does not
-- override in the generic (nor in the instance).
-- If the type in question is not abstract, and the subprogram
-- is, this will be an error if the new operation is in the
-- private part of the instance. Emit a warning now, which will
-- make the subsequent error message easier to understand.
if not Is_Abstract_Type (F_Typ)
and then Is_Abstract_Subprogram (Prev_E)
and then In_Private_Part (Current_Scope)
then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("private operation& in generic unit does not override " &
"any primitive operation of& (RM 12.3 (18))?",
New_E, New_E);
end if;
return True;
end;
end if;
......
gcc/ada/sem_dim.adb
......@@ -2247,7 +2247,8 @@ package body Sem_Dim is
Package_Name := Chars (Ent);
if Package_Name = Name_Float_IO
or else Package_Name = Name_Integer_IO
or else
Package_Name = Name_Integer_IO
then
return Chars (Scope (Ent)) = Name_Dim;
end if;
......@@ -2512,10 +2513,13 @@ package body Sem_Dim is
if Is_Entity_Name (Gen_Id) then
Ent := Entity (Gen_Id);
-- Is it really OK just to test names ??? why???
if Is_Library_Level_Entity (Ent)
and then
(Chars (Ent) = Name_Float_IO
or else Chars (Ent) = Name_Integer_IO)
or else
Chars (Ent) = Name_Integer_IO)
then
return Chars (Scope (Ent)) = Name_Dim;
end if;
......
gcc/ada/sem_dim.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
-- --
-- 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- --
......
gcc/ada/sem_res.adb
......@@ -4239,8 +4239,8 @@ package body Sem_Res is
and then Nkind (Expression (E)) = N_Function_Call
then
declare
Pool : constant Entity_Id
:= Associated_Storage_Pool (Root_Type (Typ));
Pool : constant Entity_Id :=
Associated_Storage_Pool (Root_Type (Typ));
begin
if Present (Pool)
and then
......
gcc/ada/sinput.adb
......@@ -250,6 +250,10 @@ package body Sinput is
return Name_Buffer (1 .. Name_Len);
end Build_Location_String;
-------------------
-- Check_For_BOM --
-------------------
procedure Check_For_BOM is
BOM : BOM_Kind;
Len : Natural;
......
gcc/ada/sinput.ads
......@@ -544,6 +544,14 @@ package Sinput is
-- Functional form returning a string, which does not include a terminating
-- null character. The contents of Name_Buffer is destroyed.
procedure Check_For_BOM;
-- Check if the current source starts with a BOM. Scan_Ptr needs to be at
-- the start of the current source. If the current source starts with a
-- recognized BOM, then some flags such as Wide_Character_Encoding_Method
-- are set accordingly, and the Scan_Ptr on return points past this BOM.
-- An error message is output and Unrecoverable_Error raised if a non-
-- recognized BOM is detected. The call has no effect if no BOM is found.
function Get_Column_Number (P : Source_Ptr) return Column_Number;
-- The ones-origin column number of the specified Source_Ptr value is
-- determined and returned. Tab characters if present are assumed to
......@@ -712,16 +720,6 @@ package Sinput is
-- Writes out internal tables to current tree file using the relevant
-- Table.Tree_Write routines.
procedure Check_For_BOM;
-- Check if the current source starts with a BOM. Scan_Ptr needs to be at
-- the start of the current source.
-- If the current source starts with a recognized BOM, then some flags
-- such as Wide_Character_Encoding_Method are set accordingly.
-- An exception is raised if a BOM is found that indicates an unrecognized
-- format.
-- This procedure has no effect if there is no BOM at the beginning of the
-- current source.
private
pragma Inline (File_Name);
pragma Inline (First_Mapped_Line);
......
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