+2012-02-22 Vincent Pucci <pucci@adacore.com>
+
+ * rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and
+ System_Dim_Child cases added.
+ * rtsfind.ads: Ada_Numerics,
+ Ada_Numerics_Generic_Elementary_Functions, System_Dim,
+ System_Dim_Float_IO and System_Dim_Integer_IO added to the list
+ of RTU_Id. Ada_Numerics_Child and System_Dim_Child added as
+ new RTU_Id subtypes.
+ * sem_dim.adb (Is_Dim_IO_Package_Entity): Use of
+ Rtsfind to verify the package entity is located either
+ in System.Dim.Integer_IO or in System.Dim.Float_IO.
+ (Is_Dim_IO_Package_Instantiation): Minor
+ changes. (Is_Elementary_Function_Call): Removed.
+ (Is_Elementary_Function_Entity): New routine.
+ (Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added.
+ * snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions
+ removed.
+
+2012-02-22 Vincent Pucci <pucci@adacore.com>
+
+ * sem_prag.adb: Minor reformatting.
+
+2012-02-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Find_Type_Name): When analyzing a private type
+ declaration that is the completion of a tagged incomplete type, do
+ not associate the class-wide type already created with the private
+ type to prevent order-of-elaboration issues in the back-end.
+ * exp_disp.adb (Find_Specific_Type): Find specific type of
+ a class-wide type, and handle the case of an incomplete type
+ coming either from a limited_with clause or from an incomplete
+ type declaration. Used when expanding a dispatchin call and
+ generating tag checks (minor refactoring).
+
2012-02-22 Robert Dewar <dewar@adacore.com>
* exp_ch5.adb: Add comment.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+ -- Find specific type of a class-wide type, and handle the case of an
+ -- incomplete type coming either from a limited_with clause or from an
+ -- incomplete type declaration.
+
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
end Expand_Interface_Thunk;
+ ------------------------
+ -- Find_Specific_Type --
+ ------------------------
+
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Root_Type (CW);
+
+ begin
+ if Ekind (Typ) = E_Incomplete_Type then
+ if From_With_Type (Typ) then
+ Typ := Non_Limited_View (Typ);
+ else
+ Typ := Full_View (Typ);
+ end if;
+ end if;
+
+ return Typ;
+ end Find_Specific_Type;
+
--------------------------
-- Has_CPP_Constructors --
--------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
Ada_Exceptions,
Ada_Finalization,
Ada_Interrupts,
+ Ada_Numerics,
Ada_Real_Time,
Ada_Streams,
Ada_Strings,
Ada_Interrupts_Names,
+ -- Children of Ada.Numerics
+
+ Ada_Numerics_Generic_Elementary_Functions,
+
-- Children of Ada.Real_Time
Ada_Real_Time_Delays,
System_Concat_7,
System_Concat_8,
System_Concat_9,
+ System_Dim,
System_DSA_Services,
System_DSA_Types,
System_Exception_Table,
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Dim
+
+ System_Dim_Float_IO,
+ System_Dim_Integer_IO,
+
-- Children of System.Multiprocessors
System_Multiprocessors_Dispatching_Domains,
Ada_Interrupts_Names .. Ada_Interrupts_Names;
-- Range of values for children of Ada.Interrupts
+ subtype Ada_Numerics_Child is Ada_Child
+ range Ada_Numerics_Generic_Elementary_Functions ..
+ Ada_Numerics_Generic_Elementary_Functions;
+ -- Range of values for children of Ada.Numerics
+
subtype Ada_Real_Time_Child is Ada_Child
range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
-- Range of values for children of Ada.Real_Time
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
+ subtype System_Dim_Child is RTU_Id
+ range System_Dim_Float_IO .. System_Dim_Integer_IO;
+ -- Range of values for children of System.Dim
+
subtype System_Multiprocessors_Child is RTU_Id
range System_Multiprocessors_Dispatching_Domains ..
System_Multiprocessors_Dispatching_Domains;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-- Analyze_Dimension_Function_Call --
-------------------------------------
+ -- Propagate the dimensions from the returned type to the call node. Note
+ -- that there is a special treatment for elementary function calls. Indeed
+ -- for Sqrt call, the resulting dimensions equal to half the dimensions of
+ -- the actual, and for other elementary calls, this routine check that
+ -- every actuals are dimensionless.
+
procedure Analyze_Dimension_Function_Call (N : Node_Id) is
- Name_Call : constant Node_Id := Name (N);
Actuals : constant List_Id := Parameter_Associations (N);
+ Name_Call : constant Node_Id := Name (N);
Actual : Node_Id;
Dims_Of_Actual : Dimension_Type;
Dims_Of_Call : Dimension_Type;
+ Ent : Entity_Id;
- function Is_Elementary_Function_Call return Boolean;
- -- Return True if the call is a call of an elementary function (see
+ function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean;
+ -- Given E the original subprogram entity, return True if the call is a
+ -- an elementary function call (see
-- Ada.Numerics.Generic_Elementary_Functions).
- ---------------------------------
- -- Is_Elementary_Function_Call --
- ---------------------------------
+ -----------------------------------
+ -- Is_Elementary_Function_Entity --
+ -----------------------------------
- function Is_Elementary_Function_Call return Boolean is
- Ent : Entity_Id;
+ function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (E);
begin
- if Is_Entity_Name (Name_Call) then
- Ent := Entity (Name_Call);
+ -- Check the function entity is located in
+ -- Ada.Numerics.Generic_Elementary_Functions.
- -- Check the procedure is defined in an instantiation of a generic
- -- package.
+ return
+ Loc > No_Location
+ and then
+ Is_RTU
+ (Cunit_Entity (Get_Source_Unit (Loc)),
+ Ada_Numerics_Generic_Elementary_Functions);
+ end Is_Elementary_Function_Entity;
- if Is_Generic_Instance (Scope (Ent)) then
- Ent := Cunit_Entity (Get_Source_Unit (Ent));
+ -- Start of processing for Analyze_Dimension_Function_Call
- -- Check the name of the generic package is
- -- Generic_Elementary_Functions
+ begin
+ -- Look for elementary function call
- return
- Is_Library_Level_Entity (Ent)
- and then Chars (Ent) = Name_Generic_Elementary_Functions;
- end if;
- end if;
+ if Is_Entity_Name (Name_Call) then
+ Ent := Entity (Name_Call);
- return False;
- end Is_Elementary_Function_Call;
+ -- Get the original subprogram entity following the renaming chain
- -- Start of processing for Analyze_Dimension_Function_Call
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
- begin
- -- Elementary function case
+ -- Elementary function case
- if Is_Elementary_Function_Call then
+ if Is_Elementary_Function_Entity (Ent) then
-- Sqrt function call case
- if Chars (Name_Call) = Name_Sqrt then
- Dims_Of_Call := Dimensions_Of (First (Actuals));
+ if Chars (Ent) = Name_Sqrt then
+ Dims_Of_Call := Dimensions_Of (First (Actuals));
- if Exists (Dims_Of_Call) then
- for Position in Dims_Of_Call'Range loop
- Dims_Of_Call (Position) :=
- Dims_Of_Call (Position) * Rational'(Numerator => 1,
+ if Exists (Dims_Of_Call) then
+ for Position in Dims_Of_Call'Range loop
+ Dims_Of_Call (Position) :=
+ Dims_Of_Call (Position) * Rational'(Numerator => 1,
Denominator => 2);
- end loop;
+ end loop;
- Set_Dimensions (N, Dims_Of_Call);
- end if;
+ Set_Dimensions (N, Dims_Of_Call);
+ end if;
- -- All other functions in Ada.Numerics.Generic_Elementary_Functions
- -- case. Note that all parameters here should be dimensionless.
+ -- All other elementary functions case. Note that every actual
+ -- here should be dimensionless.
- else
- Actual := First (Actuals);
- while Present (Actual) loop
- Dims_Of_Actual := Dimensions_Of (Actual);
-
- if Exists (Dims_Of_Actual) then
- Error_Msg_NE ("parameter should be dimensionless for " &
- "elementary function&",
- Actual,
- Name_Call);
- Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ else
+ Actual := First (Actuals);
+ while Present (Actual) loop
+ Dims_Of_Actual := Dimensions_Of (Actual);
+
+ if Exists (Dims_Of_Actual) then
+ Error_Msg_NE ("parameter should be dimensionless for " &
+ "elementary function&",
+ Actual,
+ Name_Call);
+ Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
+ Actual);
+ end if;
- Next (Actual);
- end loop;
+ Next (Actual);
+ end loop;
+ end if;
+
+ return;
end if;
+ end if;
- -- Other case
+ -- Other cases
- else
- Analyze_Dimension_Has_Etype (N);
- end if;
+ Analyze_Dimension_Has_Etype (N);
end Analyze_Dimension_Function_Call;
---------------------------------
function Is_Procedure_Put_Call return Boolean is
Ent : Entity_Id;
+ Loc : Source_Ptr;
begin
- -- There are three different Put routine in each generic package
- -- Check that the current procedure call is one of them
+ -- There are three different Put routines in each generic dim IO
+ -- package. Verify the current procedure call is one of them.
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
- -- Check that the name of the procedure is Put
- -- Check the procedure is defined in an instantiation of a
- -- generic package.
+ -- Get the original subprogram entity following the renaming chain
- if Chars (Name_Call) = Name_Put
- and then Is_Generic_Instance (Scope (Ent))
- then
- Ent := Cunit_Entity (Get_Source_Unit (Ent));
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
- -- Verify that the generic package is either
- -- System.Dim.Float_IO or System.Dim.Integer_IO.
+ Loc := Sloc (Ent);
- return Is_Dim_IO_Package_Entity (Ent);
- end if;
+ -- Check the name of the entity subprogram is Put and verify this
+ -- entity is located in either System.Dim.Float_IO or
+ -- System.Dim.Integer_IO.
+
+ return Chars (Ent) = Name_Put
+ and then Loc > No_Location
+ and then Is_Dim_IO_Package_Entity
+ (Cunit_Entity (Get_Source_Unit (Loc)));
end if;
return False;
-- Is_Dim_IO_Package_Entity --
------------------------------
- -- Why all this comparison of names, why not use Is_RTE and Is_RTU ???
-
function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
begin
- -- Check the package entity is standard and its scope is either
- -- System.Dim.Float_IO or System.Dim.Integer_IO.
-
- if Is_Library_Level_Entity (E)
- and then (Chars (E) = Name_Float_IO
- or else Chars (E) = Name_Integer_IO)
- then
- return Chars (Scope (E)) = Name_Dim
- and Chars (Scope (Scope (E))) = Name_System;
- end if;
+ -- Check the package entity corresponds to System.Dim.Float_IO or
+ -- System.Dim.Integer_IO.
- return False;
+ return
+ Is_RTU (E, System_Dim_Float_IO)
+ or Is_RTU (E, System_Dim_Integer_IO);
end Is_Dim_IO_Package_Entity;
-------------------------------------
function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
Gen_Id : constant Node_Id := Name (N);
- Ent : Entity_Id;
begin
- if Is_Entity_Name (Gen_Id) then
- Ent := Entity (Gen_Id);
-
- -- Verify that the instantiated package is either System.Dim.Float_IO
- -- or System.Dim.Integer_IO.
-
- return Is_Dim_IO_Package_Entity (Ent);
- end if;
+ -- Check that the instantiated package is either System.Dim.Float_IO
+ -- or System.Dim.Integer_IO.
- return False;
+ return
+ Is_Entity_Name (Gen_Id)
+ and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
end Is_Dim_IO_Package_Instantiation;
----------------
projects / platform / upstream / linaro-gcc.git / commitdiff