diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-08-01 12:13:54 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-08-01 12:13:54 +0200 |
commit | 7b4ebba52333641f9f09c8079e1d73e9f638083f (patch) | |
tree | 5b6f5e56219ca55925542658affca1b3131a869b /gcc/ada | |
parent | 798595680bb04dc570d2d6a46322c35c0de3e482 (diff) | |
download | gcc-7b4ebba52333641f9f09c8079e1d73e9f638083f.zip gcc-7b4ebba52333641f9f09c8079e1d73e9f638083f.tar.gz gcc-7b4ebba52333641f9f09c8079e1d73e9f638083f.tar.bz2 |
[multiple changes]
2014-08-01 Robert Dewar <dewar@adacore.com>
* sem_ch7.adb, einfo.adb, einfo.ads, sem_ch13.adb: Minor change of
identifier name.
2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Analyze_Object_Contract): Enable the volatility
checks when the related variable comes from source.
* sem_res.adb (Resolve_Actuals): Enable the volatility checks
when the related actual parameter comes from source. Update comment.
* freeze.adb (Freeze_Record_Type): Do not freeze the designated
type of an array of pointers when the designated type is
class-wide and its root type is the record being currently frozen.
2014-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): Preserve Ekind
of renaming declaration created for domain of iteration.
* sem_aggr.adb (Resolve_Array_Aggregate): Better placement
for error messages on aggregates whose index subtypes have
predicates. The new placement avoids posting messages on previous
subtype declarations rather than on the aggregate itself.
* sem_disp.adb (Is_Inherited_Public_Operation): New predicate for
Add_Dispatching_Operation, to handle properly the overriding of
the predefined operations on controlled types, when the partial
view of a type is not visibly controlled.
2014-08-01 Ben Brosgol <brosgol@adacore.com>
* gnat_ugn.texi: Add tutorial on portable fixed-point types as an
appendix.
From-SVN: r213446
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
-rw-r--r-- | gcc/ada/einfo.adb | 15 | ||||
-rw-r--r-- | gcc/ada/einfo.ads | 15 | ||||
-rw-r--r-- | gcc/ada/freeze.adb | 58 | ||||
-rw-r--r-- | gcc/ada/gnat_ugn.texi | 145 | ||||
-rw-r--r-- | gcc/ada/sem_aggr.adb | 45 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 5 | ||||
-rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
-rw-r--r-- | gcc/ada/sem_ch7.adb | 2 | ||||
-rw-r--r-- | gcc/ada/sem_disp.adb | 47 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 10 |
12 files changed, 322 insertions, 73 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 444d4f7..31bc891 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2014-08-01 Robert Dewar <dewar@adacore.com> + + * sem_ch7.adb, einfo.adb, einfo.ads, sem_ch13.adb: Minor change of + identifier name. + +2014-08-01 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb (Analyze_Object_Contract): Enable the volatility + checks when the related variable comes from source. + * sem_res.adb (Resolve_Actuals): Enable the volatility checks + when the related actual parameter comes from source. Update comment. + * freeze.adb (Freeze_Record_Type): Do not freeze the designated + type of an array of pointers when the designated type is + class-wide and its root type is the record being currently frozen. + +2014-08-01 Ed Schonberg <schonberg@adacore.com> + + * sem_ch5.adb (Analyze_Iterator_Specification): Preserve Ekind + of renaming declaration created for domain of iteration. + * sem_aggr.adb (Resolve_Array_Aggregate): Better placement + for error messages on aggregates whose index subtypes have + predicates. The new placement avoids posting messages on previous + subtype declarations rather than on the aggregate itself. + * sem_disp.adb (Is_Inherited_Public_Operation): New predicate for + Add_Dispatching_Operation, to handle properly the overriding of + the predefined operations on controlled types, when the partial + view of a type is not visibly controlled. + +2014-08-01 Ben Brosgol <brosgol@adacore.com> + + * gnat_ugn.texi: Add tutorial on portable fixed-point types as an + appendix. + 2014-08-01 Hristian Kirtchev <kirtchev@adacore.com> * einfo.adb (Is_Hidden_Non_Overridden_Subprogram): Remove the diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 3b5219b..84e7763 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -269,8 +269,7 @@ package body Einfo is -- the spec of Einfo for further details. -- Is_Inlined_Always Flag1 - -- Is_Hidden_Non_Overridden_Subprogram - -- Flag2 + -- Is_Hidden_Non_Overridden_Subpgm Flag2 -- Is_Frozen Flag4 -- Has_Discriminants Flag5 -- Is_Dispatching_Operation Flag6 @@ -2066,10 +2065,10 @@ package body Einfo is return Flag57 (Id); end Is_Hidden; - function Is_Hidden_Non_Overridden_Subprogram (Id : E) return B is + function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B is begin return Flag2 (Id); - end Is_Hidden_Non_Overridden_Subprogram; + end Is_Hidden_Non_Overridden_Subpgm; function Is_Hidden_Open_Scope (Id : E) return B is begin @@ -4847,10 +4846,11 @@ package body Einfo is Set_Flag57 (Id, V); end Set_Is_Hidden; - procedure Set_Is_Hidden_Non_Overridden_Subprogram (Id : E; V : B := True) is + procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); Set_Flag2 (Id, V); - end Set_Is_Hidden_Non_Overridden_Subprogram; + end Set_Is_Hidden_Non_Overridden_Subpgm; procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is begin @@ -8359,8 +8359,7 @@ package body Einfo is W ("Is_Generic_Instance", Flag130 (Id)); W ("Is_Generic_Type", Flag13 (Id)); W ("Is_Hidden", Flag57 (Id)); - W ("Is_Hidden_Non_Overridden_Subprogram", - Flag2 (Id)); + W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id)); W ("Is_Hidden_Open_Scope", Flag171 (Id)); W ("Is_Immediately_Visible", Flag7 (Id)); W ("Is_Implementation_Defined", Flag254 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 18de39f..27c8f30 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2422,7 +2422,7 @@ package Einfo is -- child unit, and when compiling a private child unit (see Install_ -- Private_Declaration in sem_ch7). --- Is_Hidden_Non_Overridden_Subprogram (Flag2) +-- Is_Hidden_Non_Overridden_Subpgm (Flag2) -- Defined in all entities. Set for implicitly declared subprograms -- that require overriding or are null procedures, and are hidden by -- a non-fully conformant homograph with the same characteristics @@ -5663,7 +5663,7 @@ package Einfo is -- Is_Discriminant_Check_Function (Flag264) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) - -- Is_Hidden_Non_Overridden_Subprogram (Flag2) (non-generic case only) + -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) @@ -5957,7 +5957,7 @@ package Einfo is -- Is_Constructor (Flag76) -- Is_Eliminated (Flag124) -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) - -- Is_Hidden_Non_Overridden_Subprogram (Flag2) (non-generic case only) + -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Interrupt_Handler (Flag89) @@ -6670,7 +6670,7 @@ package Einfo is function Is_Frozen (Id : E) return B; function Is_Generic_Instance (Id : E) return B; function Is_Hidden (Id : E) return B; - function Is_Hidden_Non_Overridden_Subprogram (Id : E) return B; + function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B; function Is_Hidden_Open_Scope (Id : E) return B; function Is_Immediately_Visible (Id : E) return B; function Is_Implementation_Defined (Id : E) return B; @@ -7307,8 +7307,7 @@ package Einfo is procedure Set_Is_Generic_Instance (Id : E; V : B := True); procedure Set_Is_Generic_Type (Id : E; V : B := True); procedure Set_Is_Hidden (Id : E; V : B := True); - procedure Set_Is_Hidden_Non_Overridden_Subprogram - (Id : E; V : B := True); + procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True); procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True); procedure Set_Is_Immediately_Visible (Id : E; V : B := True); procedure Set_Is_Implementation_Defined (Id : E; V : B := True); @@ -8076,7 +8075,7 @@ package Einfo is pragma Inline (Is_Generic_Type); pragma Inline (Is_Generic_Unit); pragma Inline (Is_Hidden); - pragma Inline (Is_Hidden_Non_Overridden_Subprogram); + pragma Inline (Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Is_Hidden_Open_Scope); pragma Inline (Is_Immediately_Visible); pragma Inline (Is_Implementation_Defined); @@ -8533,7 +8532,7 @@ package Einfo is pragma Inline (Set_Is_Generic_Instance); pragma Inline (Set_Is_Generic_Type); pragma Inline (Set_Is_Hidden); - pragma Inline (Set_Is_Hidden_Non_Overridden_Subprogram); + pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Set_Is_Hidden_Open_Scope); pragma Inline (Set_Is_Immediately_Visible); pragma Inline (Set_Is_Implementation_Defined); diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index e499701..9332930 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2667,10 +2667,10 @@ package body Freeze is ------------------------ procedure Freeze_Record_Type (Rec : Entity_Id) is + ADC : Node_Id; Comp : Entity_Id; IR : Node_Id; Prev : Entity_Id; - ADC : Node_Id; Junk : Boolean; pragma Warnings (Off, Junk); @@ -3123,18 +3123,56 @@ package body Freeze is then Check_Itype (Etype (Comp)); + -- Freeze the designated type when initializing a component with + -- an aggregate in case the aggregate contains allocators. + + -- type T is ...; + -- type T_Ptr is access all T; + -- type T_Array is array ... of T_Ptr; + + -- type Rec is record + -- Comp : T_Array := (others => ...); + -- end record; + elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) - and then Present (Parent (Comp)) - and then Nkind (Parent (Comp)) = N_Component_Declaration - and then Present (Expression (Parent (Comp))) - and then Nkind (Expression (Parent (Comp))) = N_Aggregate - and then Is_Fully_Defined - (Designated_Type (Component_Type (Etype (Comp)))) then - Freeze_And_Append - (Designated_Type - (Component_Type (Etype (Comp))), N, Result); + declare + Comp_Par : constant Node_Id := Parent (Comp); + Desig_Typ : constant Entity_Id := + Designated_Type + (Component_Type (Etype (Comp))); + + begin + -- The only case when this sort of freezing is not done is + -- when the designated type is class-wide and the root type + -- is the record owning the component. This scenario results + -- in a circularity because the class-wide type requires + -- primitives that have not been created yet as the root + -- type is in the process of being frozen. + + -- type Rec is tagged; + -- type Rec_Ptr is access all Rec'Class; + -- type Rec_Array is array ... of Rec_Ptr; + + -- type Rec is record + -- Comp : Rec_Array := (others => ...); + -- end record; + + if Is_Class_Wide_Type (Desig_Typ) + and then Root_Type (Desig_Typ) = Rec + then + null; + + elsif Is_Fully_Defined (Desig_Typ) + and then Present (Comp_Par) + and then Nkind (Comp_Par) = N_Component_Declaration + and then Present (Expression (Comp_Par)) + and then Nkind (Expression (Comp_Par)) = N_Aggregate + then + Freeze_And_Append (Desig_Typ, N, Result); + end if; + end; end if; Prev := Comp; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 83be002..a63aa76 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -190,6 +190,7 @@ AdaCore@* * Overflow Check Handling in GNAT:: * Conditional Compilation:: * Inline Assembler:: +* Writing Portable Fixed-Point Declarations:: * Compatibility and Porting Guide:: * Microsoft Windows Topics:: * Mac OS Topics:: @@ -427,6 +428,10 @@ both with Ada in general and with GNAT facilities in particular. in an Ada program. @item +@ref{Writing Portable Fixed-Point Declarations}, gives some guidance on +defining portable fixed-point types. + +@item @ref{Compatibility and Porting Guide}, contains sections on compatibility of GNAT with other Ada development environments (including Ada 83 systems), to assist in porting code from those environments. @@ -26410,6 +26415,146 @@ problems. @c END OF INLINE ASSEMBLER CHAPTER @c =============================== + +@c ***************************************** +@c Writing Portable Fixed-Point Declarations +@c ***************************************** +@node Writing Portable Fixed-Point Declarations +@appendix Writing Portable Fixed-Point Declarations +@cindex Fixed-point types (writing portable declarations) + +@noindent +The Ada Reference Manual gives an implementation freedom to choose bounds +that are narrower by @code{Small} from the given bounds. +For example, if we write + +@smallexample @c ada + type F1 is delta 1.0 range -128.0 .. +128.0; +@end smallexample + +@noindent +then the implementation is allowed to choose -128.0 .. +127.0 if it +likes, but is not required to do so. + +This leads to possible portability problems, so let's have a closer +look at this, and figure out how to avoid these problems. + +First, why does this freedom exist, and why would an implementation +take advantage of it? To answer this, take a closer look at the type +declaration for @code{F1} above. If the compiler uses the given bounds, +it would need 9 bits to hold the largest positive value (and typically +that means 16 bits on all machines). But if the implementation chooses +the +127.0 bound then it can fit values of the type in 8 bits. + +Why not make the user write +127.0 if that's what is wanted? +The rationale is that if you are thinking of fixed point +as a kind of ``poor man's floating-point'', then you don't want +to be thinking about the scaled integers that are used in its +representation. Let's take another example: + +@smallexample @c ada + type F2 is delta 2.0**(-15) range -1.0 .. +1.0; +@end smallexample + +@noindent +Looking at this declaration, it seems casually as though +it should fit in 16 bits, but again that extra positive value ++1.0 has the scaled integer equivalent of 2**15 which is one too +big for signed 16 bits. The implementation can treat this as: + +@smallexample @c ada + type F2 is delta 2.0**(-15) range -1.0 .. +1.0-(2.0**(-15)); +@end smallexample + +@noindent +and the Ada language design team felt that this was too annoying +to require. We don't need to debate this decision at this point, +since it is well established (the rule about narrowing the ranges +dates to Ada 83). + +But the important point is that an implementation is not required +to do this narrowing, so we have a potential portability problem. +We could imagine three types of implementation: + +@enumerate a +@item +those that narrow the range automatically if they can figure +out that the narrower range will allow storage in a smaller machine unit, + +@item +those that will narrow only if forced to by a @code{'Size} clause, and + +@item +those that will never narrow. +@end enumerate + +@noindent +Now if we are language theoreticians, we can imagine a fourth +approach: is to narrow all the time, e.g. to treat + +@smallexample @c ada + type F3 is delta 1.0 range -10.0 .. +23.0; +@end smallexample + +@noindent +as though it had been written: + +@smallexample @c ada + type F3 is delta 1.0 range -9.0 .. +22.0; +@end smallexample + +@noindent +But although technically allowed, such a behavior would be hostile and silly, +and no real compiler would do this. All real compilers will fall into one of +the categories (a), (b) or (c) above. + +So, how do you get the compiler to do what you want? The answer is give the +actual bounds you want, and then use a @code{'Small} clause and a +@code{'Size} clause to absolutely pin down what the compiler does. +E.g., for @code{F2} above, we will write: + +@smallexample @c ada +@group + My_Small : constant := 2.0**(-15); + My_First : constant := -1.0; + My_Last : constant := +1.0 - My_Small; + + type F2 is delta My_Small range My_First .. My_Last; +@end group +@end smallexample + +@noindent +and then add + +@smallexample @c ada +@group + for F2'Small use my_Small; + for F2'Size use 16; +@end group +@end smallexample + +@noindent +In practice all compilers will do the same thing here and will give you +what you want, so the above declarations are fully portable. If you really +want to play language lawyer and guard against ludicrous behavior by the +compiler you could add + +@smallexample @c ada +@group + Test1 : constant := 1 / Boolean'Pos (F2'First = My_First); + Test2 : constant := 1 / Boolean'Pos (F2'Last = My_Last); +@end group +@end smallexample + +@noindent +One or other or both are allowed to be illegal if the compiler is +behaving in a silly manner, but at least the silly compiler will not +get away with silently messing with your (very clear) intentions. + +If you follow this scheme you will be guaranteed that your fixed-point +types will be portable. + + @c *********************************** @c * Compatibility and Porting Guide * @c *********************************** diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index e5dfcaa..3ebaa7f 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2230,30 +2230,37 @@ package body Sem_Aggr is if Lo_Val > Hi_Val + 1 then - -- Set location for flag, if the choice is an - -- explicit Range, then point to the low bound, - -- otherwise just point to the choice. + declare + Error_Node : Node_Id; - Choice := Table (J).Choice; + begin + -- If the choice is the bound of a range in + -- a subtype indication, it is not in the + -- source lists for the aggregate itself, so + -- post the error on the aggregate. Otherwise + -- post it on choice itself. - if Nkind (Choice) = N_Range then - Choice := Low_Bound (Choice); - end if; + Choice := Table (J).Choice; - -- Now post appropriate message + if Is_List_Member (Choice) then + Error_Node := Choice; + else + Error_Node := N; + end if; - if Hi_Val + 1 = Lo_Val - 1 then - Error_Msg_N - ("missing index value in array aggregate!", - Choice); - else - Error_Msg_N - ("missing index values in array aggregate!", - Choice); - end if; + if Hi_Val + 1 = Lo_Val - 1 then + Error_Msg_N + ("missing index value " + & "in array aggregate!", Error_Node); + else + Error_Msg_N + ("missing index values " + & "in array aggregate!", Error_Node); + end if; - Output_Bad_Choices - (Hi_Val + 1, Lo_Val - 1, Choice); + Output_Bad_Choices + (Hi_Val + 1, Lo_Val - 1, Error_Node); + end; end if; end loop; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 06d5752..76c7a70 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9981,13 +9981,13 @@ package body Sem_Ch13 is and then Is_Non_Overridden_Or_Null_Procedure (Prim) and then not Fully_Conformant (Prim, Subp_Id) then - Set_Is_Hidden_Non_Overridden_Subprogram (Prim); - Set_Is_Immediately_Visible (Prim, False); - Set_Is_Potentially_Use_Visible (Prim, False); + Set_Is_Hidden_Non_Overridden_Subpgm (Prim); + Set_Is_Immediately_Visible (Prim, False); + Set_Is_Potentially_Use_Visible (Prim, False); - Set_Is_Hidden_Non_Overridden_Subprogram (Subp_Id); - Set_Is_Immediately_Visible (Subp_Id, False); - Set_Is_Potentially_Use_Visible (Subp_Id, False); + Set_Is_Hidden_Non_Overridden_Subpgm (Subp_Id); + Set_Is_Immediately_Visible (Subp_Id, False); + Set_Is_Potentially_Use_Visible (Subp_Id, False); end if; Next_Elmt (Prim_Elmt); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 53e0b47..e9f3061 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3037,9 +3037,10 @@ package body Sem_Ch3 is else pragma Assert (Ekind (Obj_Id) = E_Variable); -- The following checks are only relevant when SPARK_Mode is on as - -- they are not standard Ada legality rules. + -- they are not standard Ada legality rules. Internally generated + -- temporaries are ignored. - if SPARK_Mode = On then + if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then if Is_Effectively_Volatile (Obj_Id) then -- The declaration of an effectively volatile object must diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 5013bcd..4bbd42f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1853,11 +1853,8 @@ package body Sem_Ch5 is -- The name in the renaming declaration may be a function call. -- Indicate that it does not come from source, to suppress - -- spurious warnings on renamings of parameterless functions, a - -- common enough idiom in user-defined iterators. The entity of - -- the renaming must be a variable, because user- defined Iterate - -- function may have in-out parameters, even if predefined ones do - -- not. + -- spurious warnings on renamings of parameterless functions, + -- a common enough idiom in user-defined iterators. Decl := Make_Object_Renaming_Declaration (Loc, @@ -1870,7 +1867,6 @@ package body Sem_Ch5 is Rewrite (Name (N), New_Occurrence_Of (Id, Loc)); Set_Etype (Id, Typ); Set_Etype (Name (N), Typ); - Set_Ekind (Id, E_Variable); end; -- Container is an entity or an array with uncontrolled components, or diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 5f110ec..f75b6c1 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1986,7 +1986,7 @@ package body Sem_Ch7 is -- a tagged type back into visibility if they have non-conformant -- homographs (Ada RM 8.3 12.3/2). - elsif Is_Hidden_Non_Overridden_Subprogram (Id) then + elsif Is_Hidden_Non_Overridden_Subpgm (Id) then null; else diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index b764782..35f6181 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -86,6 +86,10 @@ package body Sem_Disp is -- This routine does not search for non-hidden primitives since they are -- covered by the normal Ada 2005 rules. + function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean; + -- Check whether a primitive operation is inherited from an operation + -- declared in the visible part of its package. + ------------------------------- -- Add_Dispatching_Operation -- ------------------------------- @@ -1233,9 +1237,17 @@ package body Sem_Disp is Check_Subtype_Conformant (Subp, Ovr_Subp); + -- A primitive operation with the name of a primitive controlled + -- operation does not override a non-visible overriding controlled + -- operation, i.e. one declared in a private part when the full + -- view of a type is controlled. Conversely, it will override a + -- visible operation that may be declared in a partial view when + -- the full view is controlled. + if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize) and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) + and then not Is_Inherited_Public_Operation (Ovr_Subp) then Set_Overridden_Operation (Subp, Empty); @@ -2159,6 +2171,27 @@ package body Sem_Disp is and then Is_Interface (Find_Dispatching_Type (E)); end Is_Null_Interface_Primitive; + ----------------------------------- + -- Is_Inherited_Public_Operation -- + ----------------------------------- + + function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is + Prim : constant Entity_Id := Alias (Op); + Scop : constant Entity_Id := Scope (Prim); + Pack_Decl : Node_Id; + + begin + if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then + Pack_Decl := Unit_Declaration_Node (Scop); + return Nkind (Pack_Decl) = N_Package_Declaration + and then List_Containing (Unit_Declaration_Node (Prim)) = + Visible_Declarations (Specification (Pack_Decl)); + + else + return False; + end if; + end Is_Inherited_Public_Operation; + -------------------------- -- Is_Tag_Indeterminate -- -------------------------- @@ -2222,8 +2255,7 @@ package body Sem_Disp is elsif Nkind (Orig_Node) = N_Attribute_Reference and then Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input - and then - Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference + and then Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference then return True; @@ -2267,9 +2299,7 @@ package body Sem_Disp is -- was malformed, and an error must have been emitted already. Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (Elmt) - and then Node (Elmt) /= Prev_Op - loop + while Present (Elmt) and then Node (Elmt) /= Prev_Op loop Next_Elmt (Elmt); end loop; @@ -2304,9 +2334,8 @@ package body Sem_Disp is Replace_Elmt (Elmt, New_Op); end if; - if Ada_Version >= Ada_2005 - and then Has_Interfaces (Tagged_Type) - then + if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then + -- Ada 2005 (AI-251): Update the attribute alias of all the aliased -- entities of the overridden primitive to reference New_Op, and -- also propagate the proper value of Is_Abstract_Subprogram. Verify diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 2d5766e..38c1017 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4325,10 +4325,12 @@ package body Sem_Res is end if; -- The following checks are only relevant when SPARK_Mode is on as - -- they are not standard Ada legality rule. + -- they are not standard Ada legality rule. Internally generated + -- temporaries are ignored. if SPARK_Mode = On and then Is_Effectively_Volatile_Object (A) + and then Comes_From_Source (A) then -- An effectively volatile object may act as an actual -- parameter when the corresponding formal is of a non-scalar @@ -4353,9 +4355,9 @@ package body Sem_Res is -- Detect an external variable with an enabled property that -- does not match the mode of the corresponding formal in a - -- procedure call. - - -- why only procedure calls ??? + -- procedure call. Functions are not considered because they + -- cannot have effectively volatile formal parameters in the + -- first place. if Ekind (Nam) = E_Procedure and then Is_Entity_Name (A) |