+2010-06-22 Robert Dewar <dewar@adacore.com>
+
+ * s-rannum.adb: Minor reformatting.
+
+2010-06-22 Javier Miranda <miranda@adacore.com>
+
+ * sem_aux.adb, sem_aux.ads, sem_util.adb, sem_util.ads, sem_elim.adb,
+ exp_cg.adb: Minor code reorganization: Move routine Ultimate_Alias from
+ package Sem_Util to package Sem_Aux.
+
+2010-06-22 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_Secondary_DT, Make_DT): Minor code cleanup:
+ remove useless restriction on imported routines when building the
+ dispatch tables.
+
+2010-06-22 Robert Dewar <dewar@adacore.com>
+
+ * cstand.adb (Create_Standard): Set Has_Pragma_Pack for standard string
+ types.
+
+2010-06-22 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch4.adb (Collect_Generic_Type_Ops): Protect code that handles
+ generic subprogram declarations to ensure proper context. Add missing
+ support for generic actuals.
+ (Try_Primitive_Operation): Add missing support for concurrent types that
+ have no Corresponding_Record_Type. Required to diagnose errors compiling
+ generics or when compiling with no code generation (-gnatc).
+ * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Do not build
+ the corresponding record type.
+ * sem_disp.ads, sem_disp.adb (Check_Dispatching_Operation): Complete
+ documentation. Do minimum decoration when processing a primitive of a
+ concurrent tagged type that covers interfaces. Required to diagnose
+ errors in the Object.Operation notation compiling generics or under
+ -gnatc.
+ * exp_ch9.ads, exp_ch9.adb (Build_Corresponding_Record): Add missing
+ propagation of attribute Interface_List to the corresponding record.
+ (Expand_N_Task_Type_Declaration): Code cleanup.
+ (Expand_N_Protected_Type_Declaration): Code cleanup.
+
2010-06-22 Matthew Heaney <heaney@adacore.com>
* a-convec.adb, a-coinve.adb: Removed 64-bit types Int and UInt.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_String), Tdef_Node);
- Set_Ekind (Standard_String, E_String_Type);
- Set_Etype (Standard_String, Standard_String);
- Set_Component_Type (Standard_String, Standard_Character);
- Set_Component_Size (Standard_String, Uint_8);
- Init_Size_Align (Standard_String);
- Set_Alignment (Standard_String, Uint_1);
+ Set_Ekind (Standard_String, E_String_Type);
+ Set_Etype (Standard_String, Standard_String);
+ Set_Component_Type (Standard_String, Standard_Character);
+ Set_Component_Size (Standard_String, Uint_8);
+ Init_Size_Align (Standard_String);
+ Set_Alignment (Standard_String, Uint_1);
+ Set_Has_Pragma_Pack (Standard_String, True);
-- On targets where a storage unit is larger than a byte (such as AAMP),
-- pragma Pack has a real effect on the representation of type String,
Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node));
Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node);
- Set_Ekind (Standard_Wide_String, E_String_Type);
- Set_Etype (Standard_Wide_String, Standard_Wide_String);
- Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
- Set_Component_Size (Standard_Wide_String, Uint_16);
- Init_Size_Align (Standard_Wide_String);
+ Set_Ekind (Standard_Wide_String, E_String_Type);
+ Set_Etype (Standard_Wide_String, Standard_Wide_String);
+ Set_Component_Type (Standard_Wide_String, Standard_Wide_Character);
+ Set_Component_Size (Standard_Wide_String, Uint_16);
+ Init_Size_Align (Standard_Wide_String);
+ Set_Has_Pragma_Pack (Standard_Wide_String, True);
-- Set index type of Wide_String
Set_Component_Size (Standard_Wide_Wide_String, Uint_32);
Init_Size_Align (Standard_Wide_Wide_String);
Set_Is_Ada_2005_Only (Standard_Wide_Wide_String);
+ Set_Has_Pragma_Pack (Standard_Wide_Wide_String, True);
-- Set index type of Wide_Wide_String
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
+with Sem_Aux; use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- Build a specification for a function implementing the protected entry
-- barrier of the specified entry body.
+ function Build_Corresponding_Record
+ (N : Node_Id;
+ Ctyp : Node_Id;
+ Loc : Source_Ptr) return Node_Id;
+ -- Common to tasks and protected types. Copy discriminant specifications,
+ -- build record declaration. N is the type declaration, Ctyp is the
+ -- concurrent entity (task type or protected type).
+
function Build_Entry_Count_Expression
(Concurrent_Type : Node_Id;
Component_List : List_Id;
-- record is "limited tagged". It is "limited" to reflect the underlying
-- limitedness of the task or protected object that it represents, and
-- ensuring for example that it is properly passed by reference. It is
- -- "tagged" to give support to dispatching calls through interfaces (Ada
- -- 2005: AI-345)
+ -- "tagged" to give support to dispatching calls through interfaces. We
+ -- propagate here the list of interfaces covered by the concurrent type
+ -- (Ada 2005: AI-345).
return
Make_Full_Type_Declaration (Loc,
Component_Items => Cdecls),
Tagged_Present =>
Ada_Version >= Ada_05 and then Is_Tagged_Type (Ctyp),
+ Interface_List => Interface_List (N),
Limited_Present => True));
end Build_Corresponding_Record;
Cdecls := Component_Items (Component_List (Type_Definition (Rec_Decl)));
- -- Ada 2005 (AI-345): Propagate the attribute that contains the list
- -- of implemented interfaces.
-
- Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
Qualify_Entity_Names (N);
-- If the type has discriminants, their occurrences in the declaration
Rec_Decl := Build_Corresponding_Record (N, Tasktyp, Loc);
- -- Ada 2005 (AI-345): Propagate the attribute that contains the list
- -- of implemented interfaces.
-
- Set_Interface_List (Type_Definition (Rec_Decl), Interface_List (N));
-
Rec_Ent := Defining_Identifier (Rec_Decl);
Cdecls := Component_Items (Component_List
(Type_Definition (Rec_Decl)));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- Task_Id of the associated task as the parameter. The caller is
-- responsible for analyzing and resolving the resulting tree.
- function Build_Corresponding_Record
- (N : Node_Id;
- Ctyp : Node_Id;
- Loc : Source_Ptr) return Node_Id;
- -- Common to tasks and protected types. Copy discriminant specifications,
- -- build record declaration. N is the type declaration, Ctyp is the
- -- concurrent entity (task type or protected type).
-
function Build_Entry_Names (Conc_Typ : Entity_Id) return Node_Id;
-- Create the statements which populate the entry names array of a task or
-- protected type. The statements are wrapped inside a block due to a local
-- are located in a separate dispatch table; skip also
-- abstract and eliminated primitives.
- -- Why do we skip imported primitives???
-
if not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (Alias (Prim))
- and then not Is_Imported (Alias (Prim))
and then not Is_Eliminated (Alias (Prim))
and then Find_Dispatching_Type
(Interface_Alias (Prim)) = Iface
-- to build secondary dispatch tables; skip also abstract
-- and eliminated primitives.
- -- Why do we skip imported primitives???
-
if not Is_Predefined_Dispatching_Operation (Prim)
and then not Is_Predefined_Dispatching_Operation (E)
and then not Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (E)
- and then not Is_Imported (E)
and then not Is_Eliminated (E)
then
pragma Assert
-- --
------------------------------------------------------------------------------
-with Ada.Calendar; use Ada.Calendar;
+with Ada.Calendar; use Ada.Calendar;
with Ada.Unchecked_Conversion;
-with Interfaces; use Interfaces;
+
+with Interfaces; use Interfaces;
use Ada;
Image_Numeral_Length : constant := Max_Image_Width / N;
subtype Image_String is String (1 .. Max_Image_Width);
- -- Utility functions
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Init (Gen : out Generator; Initiator : Unsigned_32);
-- Perform a default initialization of the state of Gen. The resulting
-- assuming that Unsigned is large enough to hold the bits of a mantissa
-- for type Real.
+ ---------------------------
+ -- Random_Float_Template --
+ ---------------------------
+
function Random_Float_Template (Gen : Generator) return Real is
pragma Compile_Time_Error
if Real'Machine_Radix /= 2 then
return Real'Machine
(Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size));
+
else
declare
type Bit_Count is range 0 .. 4;
subtype T is Real'Base;
Trailing_Ones : constant array (Unsigned_32 range 0 .. 15)
- of Bit_Count
- := (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2,
+ of Bit_Count :=
+ (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2,
2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3,
2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2,
2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4);
(Unsigned'Size - T'Machine_Mantissa + 1);
-- Random bits left over after selecting mantissa
- Mantissa : Unsigned;
- X : Real; -- Scaled mantissa
- R : Unsigned_32; -- Supply of random bits
- R_Bits : Natural; -- Number of bits left in R
+ Mantissa : Unsigned;
- K : Bit_Count; -- Next decrement to exponent
- begin
+ X : Real;
+ -- Scaled mantissa
+
+ R : Unsigned_32;
+ -- Supply of random bits
+
+ R_Bits : Natural;
+ -- Number of bits left in R
+
+ K : Bit_Count;
+ -- Next decrement to exponent
+ begin
Mantissa := Random (Gen) / 2**Extra_Bits;
R := Unsigned_32 (Mantissa mod 2**Extra_Bits);
R_Bits := Extra_Bits;
X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact
- if Extra_Bits < 4 and then R < 2**Extra_Bits - 1 then
+ if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then
+
-- We got lucky and got a zero in our few extra bits
+
K := Trailing_Ones (R);
else
end loop Find_Zero;
end if;
- -- K has the count of trailing ones not reflected yet in X.
- -- The following multiplication takes care of that, as well
- -- as the correction to move the radix point to the left of
- -- the mantissa. Doing it at the end avoids repeated rounding
- -- errors in the exceedingly unlikely case of ever having
- -- a subnormal result.
+ -- K has the count of trailing ones not reflected yet in X. The
+ -- following multiplication takes care of that, as well as the
+ -- correction to move the radix point to the left of the mantissa.
+ -- Doing it at the end avoids repeated rounding errors in the
+ -- exceedingly unlikely case of ever having a subnormal result.
X := X * Pow_Tab (K);
end if;
end Random_Float_Template;
+ ------------
+ -- Random --
+ ------------
+
function Random (Gen : Generator) return Float is
function F is new Random_Float_Template (Unsigned_32, Float);
begin
-- Ignore different-size warnings here; since GNAT's handling
-- is correct.
- pragma Warnings ("Z");
+ pragma Warnings ("Z"); -- better to use msg string! ???
function Conv_To_Unsigned is
new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64);
function Conv_To_Result is
I, J : Integer;
begin
- Init (Gen, 19650218);
+ Init (Gen, 19650218); -- please give this constant a name ???
I := 1;
J := 0;
Obsolescent_Warnings.Tree_Write;
end Tree_Write;
+ --------------------
+ -- Ultimate_Alias --
+ --------------------
+
+ function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := Prim;
+
+ begin
+ while Present (Alias (E)) loop
+ pragma Assert (Alias (E) /= E);
+ E := Alias (E);
+ end loop;
+
+ return E;
+ end Ultimate_Alias;
+
end Sem_Aux;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
function Number_Discriminants (Typ : Entity_Id) return Pos;
-- Typ is a type with discriminants, yields number of discriminants in type
+ function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
+ pragma Inline (Ultimate_Alias);
+ -- Return the last entity in the chain of aliased entities of Prim. If Prim
+ -- has no alias return Prim.
+
end Sem_Aux;
-- Scan the list of generic formals to find subprograms
-- that may have a first controlling formal of the type.
- declare
- Decl : Node_Id;
-
- begin
- Decl :=
- First (Generic_Formal_Declarations
- (Unit_Declaration_Node (Scope (T))));
- while Present (Decl) loop
- if Nkind (Decl) in N_Formal_Subprogram_Declaration then
- Subp := Defining_Entity (Decl);
- Check_Candidate;
- end if;
-
- Next (Decl);
- end loop;
- end;
+ if Nkind (Unit_Declaration_Node (Scope (T)))
+ = N_Generic_Subprogram_Declaration
+ then
+ declare
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ First (Generic_Formal_Declarations
+ (Unit_Declaration_Node (Scope (T))));
+ while Present (Decl) loop
+ if Nkind (Decl) in N_Formal_Subprogram_Declaration then
+ Subp := Defining_Entity (Decl);
+ Check_Candidate;
+ end if;
+ Next (Decl);
+ end loop;
+ end;
+ end if;
return Candidates;
else
-- declaration or body (either the one that declares T, or a
-- child unit).
- Subp := First_Entity (Scope (T));
+ -- For a subtype representing a generic actual type, go to the
+ -- base type.
+
+ if Is_Generic_Actual_Type (T) then
+ Subp := First_Entity (Scope (Base_Type (T)));
+ else
+ Subp := First_Entity (Scope (T));
+ end if;
+
while Present (Subp) loop
if Is_Overloadable (Subp) then
Check_Candidate;
-- corresponding record (base) type.
if Is_Concurrent_Type (Obj_Type) then
- if not Present (Corresponding_Record_Type (Obj_Type)) then
- return False;
+ if Present (Corresponding_Record_Type (Obj_Type)) then
+ Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
+ Elmt := First_Elmt (Primitive_Operations (Corr_Type));
+ else
+ Corr_Type := Obj_Type;
+ Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
end if;
- Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
- Elmt := First_Elmt (Primitive_Operations (Corr_Type));
-
elsif not Is_Generic_Type (Obj_Type) then
Corr_Type := Obj_Type;
Elmt := First_Elmt (Primitive_Operations (Obj_Type));
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of protected type while inside a generic.
- -- The corresponding record is needed for various semantic checks.
-
- if Ada_Version >= Ada_05
- and then Inside_A_Generic
- then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (T)));
- end if;
-
Analyze (Protected_Definition (N));
-- Protected types with entries are controlled (because of the
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- Perform minimal expansion of the task type while inside a generic
- -- context. The corresponding record is needed for various semantic
- -- checks.
-
- if Inside_A_Generic then
- Insert_After_And_Analyze (N,
- Build_Corresponding_Record (N, T, Sloc (T)));
- end if;
-
if Present (Task_Definition (N)) then
Analyze_Task_Definition (Task_Definition (N));
end if;
Set_Is_Dispatching_Operation (Subp, False);
Tagged_Type := Find_Dispatching_Type (Subp);
- -- Ada 2005 (AI-345)
+ -- Ada 2005 (AI-345): Use the corresponding record (if available).
+ -- Required because primitives of concurrent types are be attached
+ -- to the corresponding record (not to the concurrent type).
if Ada_Version >= Ada_05
and then Present (Tagged_Type)
and then Is_Concurrent_Type (Tagged_Type)
+ and then Present (Corresponding_Record_Type (Tagged_Type))
then
- -- Protect the frontend against previously detected errors
-
- if No (Corresponding_Record_Type (Tagged_Type)) then
- return;
- end if;
-
Tagged_Type := Corresponding_Record_Type (Tagged_Type);
end if;
end if;
end if;
+ -- If the tagged type is a concurrent type then we must be compiling
+ -- with no code generation (we are either compiling a generic unit or
+ -- compiling under -gnatc mode) because we have previously tested that
+ -- no serious errors has been reported. In this case we do not add the
+ -- primitive to the list of primitives of Tagged_Type but we leave the
+ -- primitive decorated as a dispatching operation to be able to analyze
+ -- and report errors associated with the Object.Operation notation.
+
+ elsif Is_Concurrent_Type (Tagged_Type) then
+ pragma Assert (not Expander_Active);
+ null;
+
-- If no old subprogram, then we add this as a dispatching operation,
-- but we avoid doing this if an error was posted, to prevent annoying
-- cascaded errors.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
-- if it has a parameter of this type and is defined at a proper place for
-- primitive operations (new primitives are only defined in package spec,
-- overridden operation can be defined in any scope). If Old_Subp is not
- -- Empty we are in the overriding case.
+ -- Empty we are in the overriding case. If the tagged type associated with
+ -- Subp is a concurrent type (case that occurs when the type is declared in
+ -- a generic because the analysis of generics disables generation of the
+ -- corresponding record) then this routine does does not add "Subp" to the
+ -- list of primitive operations but leaves Subp decorated as dispatching
+ -- operation to enable checks associated with the Object.Operation notation
procedure Check_Operation_From_Incomplete_Type
(Subp : Entity_Id;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinput; use Sinput;
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
- --------------------
- -- Ultimate_Alias --
- --------------------
-
- function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
- E : Entity_Id := Prim;
-
- begin
- while Present (Alias (E)) loop
- pragma Assert (Alias (E) /= E);
- E := Alias (E);
- end loop;
-
- return E;
- end Ultimate_Alias;
-
--------------------------
-- Unit_Declaration_Node --
--------------------------
function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ
- function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
- pragma Inline (Ultimate_Alias);
- -- Return the last entity in the chain of aliased entities of Prim. If Prim
- -- has no alias return Prim.
-
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the
projects / gcc.git / commitdiff