+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
-- 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.
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
(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;
(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;
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 :=
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
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);
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
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;
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,
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,
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);
"storage pool type", Pool_Type);
elsif Present (Found_Op) then
+
-- Simple pool operations can't be abstract
if Is_Abstract_Subprogram (Found_Op) then
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;
is
Agg : Aggregated_Project_List;
Ctx : Project_Context;
+
begin
Action (Project, Tree, Context);
(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
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));
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
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;
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
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;
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);
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
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
-- 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;
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;
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;
-- --
-- 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- --
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
return Name_Buffer (1 .. Name_Len);
end Build_Location_String;
+ -------------------
+ -- Check_For_BOM --
+ -------------------
+
procedure Check_For_BOM is
BOM : BOM_Kind;
Len : Natural;
-- 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
-- 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);
projects / gcc.git / commitdiff