diff options
| author | Gary Dismukes <dismukes@adacore.com> | 2007-12-19 17:25:18 +0100 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2007-12-19 17:25:18 +0100 |
| commit | 20e8cdd795e6d426ff4b7750d6fbe9f2f866fd38 (patch) | |
| tree | a4d387637bb01780bed1fc941cc8d38ce89a75f8 /gcc | |
| parent | 90067a1585088aa84dde8cc7f796d567231af202 (diff) | |
| download | gcc-20e8cdd795e6d426ff4b7750d6fbe9f2f866fd38.zip gcc-20e8cdd795e6d426ff4b7750d6fbe9f2f866fd38.tar.gz gcc-20e8cdd795e6d426ff4b7750d6fbe9f2f866fd38.tar.bz2 | |
re PR ada/34149 (GNAT crash - deeply inrerited function)
2007-12-19 Gary Dismukes <dismukes@adacore.com>
PR ada/34149
* sem_disp.adb (Check_Dispatching_Call): Augment existing test for
presence of a statically tagged operand (Present (Static_Tag)) with
test for Indeterm_Ancestor_Call when determining whether to propagate
the static tag to tag-indeterminate operands (which forces dispatching
on such calls).
(Check_Controlling_Formals): Ada2005, access parameters can have
defaults.
(Add_Dispatching_Operation, Check_Operation_From_Private_View): do
not insert subprogram in list of primitive operations if already there.
From-SVN: r131082
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/sem_disp.adb | 27 |
1 files changed, 21 insertions, 6 deletions
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 0617558..0f3f57b 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -79,8 +79,14 @@ package body Sem_Disp is New_Op : Entity_Id) is List : constant Elist_Id := Primitive_Operations (Tagged_Type); + begin - Append_Elmt (New_Op, List); + -- The dispatching operation may already be on the list, if it the + -- wrapper for an inherited function of a null extension (see exp_ch3 + -- for the construction of function wrappers). The list of primitive + -- operations must not contain duplicates. + + Append_Unique_Elmt (New_Op, List); end Add_Dispatching_Operation; ------------------------------- @@ -143,7 +149,12 @@ package body Sem_Disp is end if; if Present (Default_Value (Formal)) then - if Ekind (Etype (Formal)) = E_Anonymous_Access_Type then + + -- In Ada 2005, access parameters can have defaults + + if Ekind (Etype (Formal)) = E_Anonymous_Access_Type + and then Ada_Version < Ada_05 + then Error_Msg_N ("default not allowed for controlling access parameter", Default_Value (Formal)); @@ -471,10 +482,12 @@ package body Sem_Disp is Set_Controlling_Argument (N, Control); Check_Restriction (No_Dispatching_Calls, N); - -- If there is a statically tagged actual, check whether - -- some tag-indeterminate actual can use it. + -- If there is a statically tagged actual and a tag-indeterminate + -- call to a function of the ancestor (such as that provided by a + -- default), then treat this as a dispatching call and propagate + -- the tag to the tag-indeterminate call(s). - elsif Present (Static_Tag) then + elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then Control := Make_Attribute_Reference (Loc, Prefix => @@ -1091,8 +1104,10 @@ package body Sem_Disp is Set_Scope (Subp, Current_Scope); Tagged_Type := Find_Dispatching_Type (Subp); + -- Add Old_Subp to primitive operations if not already present. + if Present (Tagged_Type) and then Is_Tagged_Type (Tagged_Type) then - Append_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); + Append_Unique_Elmt (Old_Subp, Primitive_Operations (Tagged_Type)); -- If Old_Subp isn't already marked as dispatching then -- this is the case of an operation of an untagged private |