+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
-- 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
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
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
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));
-- 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
-- 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)
-- 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)
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;
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);
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);
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);
------------------------
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);
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;
* Overflow Check Handling in GNAT::
* Conditional Compilation::
* Inline Assembler::
+* Writing Portable Fixed-Point Declarations::
* Compatibility and Porting Guide::
* Microsoft Windows Topics::
* Mac OS Topics::
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.
@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 ***********************************
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;
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);
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
-- 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,
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
-- 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
-- --
-- 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- --
-- 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 --
-------------------------------
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);
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 --
--------------------------
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;
-- 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;
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
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
-- 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)
projects / platform / upstream / linaro-gcc.git / commitdiff