diff options
author | Javier Miranda <miranda@adacore.com> | 2009-04-29 13:29:08 +0000 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2009-04-29 15:29:08 +0200 |
commit | 236fecbf44a87814987887e5d3f03c4b8bf0c294 (patch) | |
tree | 11c0c448c05a05a2157e938de8190ca731911a8b /gcc/ada/exp_tss.adb | |
parent | 0ec21a5bb7586e74425f162f1527b508309f3345 (diff) | |
download | gcc-236fecbf44a87814987887e5d3f03c4b8bf0c294.zip gcc-236fecbf44a87814987887e5d3f03c4b8bf0c294.tar.gz gcc-236fecbf44a87814987887e5d3f03c4b8bf0c294.tar.bz2 |
sem_ch3.adb (Analyze_Object_Declaration): Disable error message associated with dyamically tagged expressions if...
2009-04-29 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Analyze_Object_Declaration): Disable error message
associated with dyamically tagged expressions if the expression
initializing a tagged type corresponds with a non default CPP
constructor.
(OK_For_Limited_Init): CPP constructor calls are OK for initialization
of limited type objects.
* sem_ch5.adb (Analyze_Assignment): Improve the error message reported
when a CPP constructor is called in an assignment. Disable also the
error message associated with dyamically tagged expressions if the
exporession initializing a tagged type corresponds with a non default
CPP constructor.
* sem_prag.adb (Analyze_Pragma): Remove code disabling the use of
non-default C++ constructors.
* sem_util.ads, sem_util.adb (Is_CPP_Constructor_Call): New subprogram.
* exp_tss.ads, exp_tss.adb (Base_Init_Proc): Add support for
non-default constructors.
(Init_Proc): Add support for non-default constructors.
* exp_disp.adb (Set_Default_Constructor): Removed.
(Set_CPP_Constructors): Code based in removed Set_Default_Constructor
but extending its functionality to handle non-default constructors.
* exp_aggr.adb (Build_Record_Aggr_Code): Add support for non-default
constructors. Minor code cleanup removing unrequired label and goto
statement.
* exp_ch3.adb (Build_Initialization_Call): Add support for non-default
constructors.
(Build_Init_Statements): Add support for non-default constructors.
(Expand_N_Object_Declaration): Add support for non-default constructors.
(Freeze_Record_Type): Replace call to Set_Default_Constructor by call
to Set_CPP_Constructors.
* exp_ch5.adb (Expand_N_Assignment_Statement): Add support for
non-default constructors.
Required to handle its use in build-in-place statements.
* gnat_rm.texi (CPP_Constructor): Document new extended use of this
pragma for non-default C++ constructors and the new compiler support
that allows the use of these constructors in record components, limited
aggregates, and extended return statements.
From-SVN: r146966
Diffstat (limited to 'gcc/ada/exp_tss.adb')
-rw-r--r-- | gcc/ada/exp_tss.adb | 73 |
1 files changed, 65 insertions, 8 deletions
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index b350644..c7e0366 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -27,6 +27,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; with Exp_Util; use Exp_Util; +with Nlists; use Nlists; with Lib; use Lib; with Restrict; use Restrict; with Rident; use Rident; @@ -40,7 +41,10 @@ package body Exp_Tss is -- Base_Init_Proc -- -------------------- - function Base_Init_Proc (Typ : Entity_Id) return Entity_Id is + function Base_Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id + is Full_Type : E; Proc : Entity_Id; @@ -55,6 +59,7 @@ package body Exp_Tss is if No (Full_Type) then return Empty; + elsif Is_Concurrent_Type (Full_Type) and then Present (Corresponding_Record_Type (Base_Type (Full_Type))) then @@ -63,16 +68,17 @@ package body Exp_Tss is -- and possibly an itype. return Init_Proc - (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type)))); + (Base_Type (Corresponding_Record_Type (Base_Type (Full_Type))), + Ref); else - Proc := Init_Proc (Base_Type (Full_Type)); + Proc := Init_Proc (Base_Type (Full_Type), Ref); if No (Proc) and then Is_Composite_Type (Full_Type) and then Is_Derived_Type (Full_Type) then - return Init_Proc (Root_Type (Full_Type)); + return Init_Proc (Root_Type (Full_Type), Ref); else return Proc; end if; @@ -183,9 +189,14 @@ package body Exp_Tss is -- Init_Proc -- --------------- - function Init_Proc (Typ : Entity_Id) return Entity_Id is + function Init_Proc + (Typ : Entity_Id; + Ref : Entity_Id := Empty) return Entity_Id + is FN : constant Node_Id := Freeze_Node (Typ); Elmt : Elmt_Id; + E1 : Entity_Id; + E2 : Entity_Id; begin if No (FN) then @@ -194,11 +205,57 @@ package body Exp_Tss is elsif No (TSS_Elist (FN)) then return Empty; - else + elsif No (Ref) then Elmt := First_Elmt (TSS_Elist (FN)); while Present (Elmt) loop if Is_Init_Proc (Node (Elmt)) then - return Node (Elmt); + if not Is_CPP_Class (Typ) then + return Node (Elmt); + + -- In case of CPP classes we are searching here for the + -- default constructor and hence we must skip non-default + -- constructors (if any) + + elsif No (Next + (First + (Parameter_Specifications (Parent (Node (Elmt)))))) + then + return Node (Elmt); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Non-default constructors are currently supported only in the + -- context of interfacing with C++ + + else pragma Assert (Is_CPP_Class (Typ)); + + -- Use the referenced function to locate the IP procedure that + -- corresponds with the C++ constructor + + Elmt := First_Elmt (TSS_Elist (FN)); + while Present (Elmt) loop + if Is_Init_Proc (Node (Elmt)) then + E1 := Next_Formal (First_Formal (Node (Elmt))); + E2 := First_Formal (Ref); + + while Present (E1) and then Present (E2) loop + if Chars (E1) /= Chars (E2) + or else Ekind (E1) /= Ekind (E2) + or else Etype (E1) /= Etype (E2) + then + exit; + end if; + + E1 := Next_Formal (E1); + E2 := Next_Formal (E2); + end loop; + + if No (E1) and then No (E2) then + return Node (Elmt); + end if; end if; Next_Elmt (Elmt); |