+2014-08-01 Robert Dewar <dewar@adacore.com>
+
+ * hostparm.ads: Put back definition of OpenVMS as False to aid
+ the transition process.
+ * sem_ch7.adb: Minor reformatting.
+ * prj-env.adb: Minor code fix.
+ * gnat_rm.texi: Complete previous change.
+ * sem_ch3.adb: Minor reformatting.
+ * sem_ch6.adb: Minor reformatting.
+ * sem_elab.adb: Minor reformatting.
+ * exp_strm.adb: Complete previous change.
+
+2014-08-01 Vincent Celier <celier@adacore.com>
+
+ * sem_warn.adb (Warn_On_Unreferenced_Entity): Do not issue a
+ warning when a constant is unreferenced and its type has pragma
+ Unreferenced_Objects.
+
+2014-08-01 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb: Flag2 is now known as
+ Is_Hidden_Non_Overridden_Subprogram.
+ (Is_Hidden_Non_Overridden_Subprogram): New routine.
+ (Set_Is_Hidden_Non_Overridden_Subprogram): New routine.
+ (Write_Entity_Fields): Output Flag2.
+ * einfo.ads: New attribute Is_Hidden_Non_Overridden_Subprogram
+ along with occurrences in entities.
+ (Is_Hidden_Non_Overridden_Subprogram): New routine and pragma Inline.
+ (Set_Is_Hidden_Non_Overridden_Subprogram): New routine
+ and pragma Inline.
+ * sem_ch7.adb (Install_Package_Entity): Do not enter implicitly
+ declared non-overriden homographs into visibility.
+ * sem_ch13.adb (Freeze_Entity_Checks): Hide all
+ implicitly declared non-overriden homographs.
+ (Hide_Non_Overridden_Subprograms): New routine.
+
2014-08-01 Robert Dewar <dewar@adacore.com>
* snames.ads-tmpl, s-os_lib.adb, s-os_lib.ads, s-fileio.adb: Remove
-- the spec of Einfo for further details.
-- Is_Inlined_Always Flag1
+ -- Is_Hidden_Non_Overridden_Subprogram
+ -- Flag2
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- Is_Dispatching_Operation Flag6
-- No_Predicate_On_Actual Flag275
-- No_Dynamic_Predicate_On_Actual Flag276
- -- (unused) Flag2
-- (unused) Flag3
-- (unused) Flag132
return Flag57 (Id);
end Is_Hidden;
+ function Is_Hidden_Non_Overridden_Subprogram (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ return Flag2 (Id);
+ end Is_Hidden_Non_Overridden_Subprogram;
+
function Is_Hidden_Open_Scope (Id : E) return B is
begin
return Flag171 (Id);
Set_Flag57 (Id, V);
end Set_Is_Hidden;
+ procedure Set_Is_Hidden_Non_Overridden_Subprogram (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;
+
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is
begin
Set_Flag171 (Id, V);
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_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)
+-- Defined in all entities. Set for implicitly declared non-generic
+-- subprograms that require overriding or are null procedures, and are
+-- hidden by a non-conformant homograph with the same characteristics
+-- (Ada RM 8.3 12.3/2).
+
-- Is_Hidden_Open_Scope (Flag171)
-- Defined in all entities. Set for a scope that contains the
-- instantiation of a child unit, and whose entities are not visible
-- 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_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Called (Flag102) (non-generic case only)
-- 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_Inlined_Always (Flag1) (non-generic case only)
-- Is_Instantiated (Flag126) (generic case only)
- -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Interrupt_Handler (Flag89)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
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_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_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_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_Open_Scope);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
-- and we are in the body of the default implementation of a 'Read
-- attribute, set target type to force a constraint check (13.13.2(35)).
-- If the type of the discriminant is currently private, add another
- -- unchecked conversion from the full view. We also do this check if
- -- this is an elementary read call in the source program (as opposed
- -- to one generated as part of a composite read).
-
- if (Nkind (Targ) = N_Identifier
- and then Is_Internal_Name (Chars (Targ))
- and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read))
- or else Comes_From_Source (N)
+ -- unchecked conversion from the full view.
+
+ if Nkind (Targ) = N_Identifier
+ and then Is_Internal_Name (Chars (Targ))
+ and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
then
Res :=
Unchecked_Convert_To (Base_Type (U_Type),
[formal_parameter_NAME =>] MECHANISM_NAME
MECHANISM_NAME ::= Value | Reference
+@end smallexample
@noindent
This pragma is identical to @code{Import_Procedure} except that the
-- --
-- S p e c --
-- --
--- 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- --
-- HOST Parameters --
---------------------
- Gnat_VMSp : Integer;
- pragma Import (C, Gnat_VMSp, "__gnat_vmsp");
-
- OpenVMS : Boolean := Gnat_VMSp /= 0;
- -- Set True for OpenVMS host. See also OpenVMS target boolean in
- -- system-vms.ads and system-vms_64.ads and OpenVMS_On_Target boolean in
- -- Targparm. This is not a constant, because it can be modified by -gnatdm.
+ OpenVMS : Boolean := False;
+ -- Set True for OpenVMS host
Direct_Separator : constant Character;
pragma Import (C, Direct_Separator, "__gnat_dir_separator");
Normalize_Pathname
(Name_Buffer (First .. Last),
Resolve_Links => Opt.Follow_Links_For_Dirs);
- New_Len : Natural;
- New_Last : Natural;
+ New_Len : Positive;
+ New_Last : Positive;
begin
-- If the absolute path was resolved and is different from
--------------------------
procedure Freeze_Entity_Checks (N : Node_Id) is
+ procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id);
+ -- Inspect the primitive operations of type Typ and hide all pairs of
+ -- implicitly declared non-overridden homographs (Ada RM 8.3 12.3/2).
+
+ -------------------------------------
+ -- Hide_Non_Overridden_Subprograms --
+ -------------------------------------
+
+ procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id) is
+ procedure Hide_Matching_Homographs
+ (Subp_Id : Entity_Id;
+ Start_Elmt : Elmt_Id);
+ -- Inspect a list of primitive operations starting with Start_Elmt
+ -- and find matching implicitly declared non-overridden homographs
+ -- of Subp_Id. If found, all matches along with Subp_Id are hidden
+ -- from all visibility.
+
+ function Is_Non_Overridden_Or_Null_Procedure
+ (Subp_Id : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id is implicitly declared non-
+ -- overridden subprogram or an implicitly declared null procedure.
+
+ ------------------------------
+ -- Hide_Matching_Homographs --
+ ------------------------------
+
+ procedure Hide_Matching_Homographs
+ (Subp_Id : Entity_Id;
+ Start_Elmt : Elmt_Id)
+ is
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+
+ begin
+ Prim_Elmt := Start_Elmt;
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+
+ -- The current primitive is implicitly declared non-overridden
+ -- homograph of Subp_Id. Hide both subprograms from visibility.
+
+ if Chars (Prim) = Chars (Subp_Id)
+ and then Ekind (Prim) = Ekind (Subp_Id)
+ and then Is_Non_Overridden_Or_Null_Procedure (Prim)
+ 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_Subprogram (Subp_Id);
+ Set_Is_Immediately_Visible (Subp_Id, False);
+ Set_Is_Potentially_Use_Visible (Subp_Id, False);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Hide_Matching_Homographs;
+
+ -----------------------------------------
+ -- Is_Non_Overridden_Or_Null_Procedure --
+ -----------------------------------------
+
+ function Is_Non_Overridden_Or_Null_Procedure
+ (Subp_Id : Entity_Id) return Boolean
+ is
+ Alias_Id : Entity_Id;
+
+ begin
+ -- The subprogram is inherited (implicitly declared), it does not
+ -- override and does not cover a primitive of an interface.
+
+ if Ekind_In (Subp_Id, E_Function, E_Procedure)
+ and then Present (Alias (Subp_Id))
+ and then No (Interface_Alias (Subp_Id))
+ and then No (Overridden_Operation (Subp_Id))
+ then
+ Alias_Id := Alias (Subp_Id);
+
+ if Requires_Overriding (Alias_Id) then
+ return True;
+
+ elsif Nkind (Parent (Alias_Id)) = N_Procedure_Specification
+ and then Null_Present (Parent (Alias_Id))
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Non_Overridden_Or_Null_Procedure;
+
+ -- Local variables
+
+ Prim_Ops : constant Elist_Id := Direct_Primitive_Operations (Typ);
+ Prim : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+
+ -- Start of processing for Hide_Non_Overridden_Subprograms
+
+ begin
+ -- Inspect the list of primitives looking for a non-overriding
+ -- inherited null procedure.
+
+ if Present (Prim_Ops) then
+ Prim_Elmt := First_Elmt (Prim_Ops);
+ while Present (Prim_Elmt) loop
+ Prim := Node (Prim_Elmt);
+ Next_Elmt (Prim_Elmt);
+
+ if Is_Non_Overridden_Or_Null_Procedure (Prim) then
+ Hide_Matching_Homographs
+ (Subp_Id => Prim,
+ Start_Elmt => Prim_Elmt);
+ end if;
+ end loop;
+ end if;
+ end Hide_Non_Overridden_Subprograms;
+
+ ---------------------
+ -- Local variables --
+ ---------------------
+
E : constant Entity_Id := Entity (N);
Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity;
-- for the generic case since it is not needed. Basically in the
-- generic case, we only need to do stuff that might generate error
-- messages or warnings.
+
+ -- Start of processing for Freeze_Entity_Checks
+
begin
-- Remember that we are processing a freezing entity. Required to
-- ensure correct decoration of internal entities associated with
Add_Internal_Interface_Entities (E);
end if;
+ -- After all forms of overriding have been resolved, a tagged type may
+ -- be left with a set of implicitly declared and possibly erroneous
+ -- abstract subprograms, null procedures and subprograms that require
+ -- overriding. If this set contains fully conformat homographs, then one
+ -- is chosen arbitrarily (already done during resolution), otherwise all
+ -- remaining non-conformant homographs must be hidden from visibility
+ -- (Ada RM 8.3 12.3/2).
+
+ if Is_Tagged_Type (E) then
+ Hide_Non_Overridden_Subprograms (E);
+ end if;
+
-- Check CPP types
if Ekind (E) = E_Record_Type
Old_C := First_Component (Typ);
while Present (Old_C) loop
if Original_Record_Component (Old_C) = Old_C
- and then Chars (Old_C) /= Name_uTag
- and then Chars (Old_C) /= Name_uParent
+ and then Chars (Old_C) /= Name_uTag
+ and then Chars (Old_C) /= Name_uParent
then
Append_Elmt (Old_C, Comp_List);
end if;
Discriminant :=
First_Stored_Discriminant (Explicitly_Discriminated_Type);
while Present (Discriminant) loop
- Append_Elmt (
- Get_Discriminant_Value (
- Discriminant, Explicitly_Discriminated_Type, Constraint),
- Expansion);
+ Append_Elmt
+ (Get_Discriminant_Value
+ (Discriminant, Explicitly_Discriminated_Type, Constraint),
+ To => Expansion);
Next_Stored_Discriminant (Discriminant);
end loop;
then
Append_Elmt
(Current_Scope,
- Private_Dependents (Base_Type (Formal_Type)));
+ To => Private_Dependents (Base_Type (Formal_Type)));
-- Freezing is delayed to ensure that Register_Prim
-- will get called for this operation, which is needed
else
Spec_Id := Current_Entity_In_Scope (Defining_Entity (N));
- if Present (Spec_Id)
- and then Is_Package_Or_Generic_Package (Spec_Id)
+ if Present (Spec_Id) and then Is_Package_Or_Generic_Package (Spec_Id)
then
Pack_Decl := Unit_Declaration_Node (Spec_Id);
-- of accessing global entities.
if Has_Pragma_Inline (E) then
- if Outer
- and then Check_Subprogram_Refs (D) = OK
+ if Outer and then Check_Subprogram_Refs (D) = OK
then
Has_Referencer_Except_For_Subprograms := True;
else
end if;
if Has_Pragma_Inline (E) or else Is_Inlined (E) then
- if Outer
- and then Check_Subprogram_Refs (D) = OK
+ if Outer and then Check_Subprogram_Refs (D) = OK
then
Has_Referencer_Except_For_Subprograms := True;
else
Write_Eol;
end if;
- if not Is_Child_Unit (Id) then
+ if Is_Child_Unit (Id) then
+ null;
+
+ -- Do not enter implicitly inherited non-overridden subprograms of
+ -- a tagged type back into visibility if they have non-conformant
+ -- homographs (Ada RM 8.3 12.3/2).
+
+ elsif Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Hidden_Non_Overridden_Subprogram (Id)
+ then
+ null;
+
+ else
Set_Is_Immediately_Visible (Id);
end if;
-
end if;
end Install_Package_Entity;
-- field. This field will be empty if the entity has already been
-- installed due to a previous call.
- if Present (Full_View (Priv))
- and then Is_Visible_Dependent (Priv)
+ if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv)
then
if Is_Private_Type (Priv) then
Deps := Private_Dependents (Priv);
or else Type_In_Use (Etype (Id))
or else Type_In_Use (Etype (First_Formal (Id)))
or else (Present (Next_Formal (First_Formal (Id)))
- and then
- Type_In_Use
- (Etype (Next_Formal (First_Formal (Id))))));
+ and then
+ Type_In_Use
+ (Etype (Next_Formal (First_Formal (Id))))));
else
if In_Use (P) and then not Is_Hidden (Id) then
-- The following test may be redundant, as this is already
-- diagnosed in sem_ch3. ???
- if Is_Indefinite_Subtype (Full)
+ if Is_Indefinite_Subtype (Full)
and then not Is_Indefinite_Subtype (Id)
then
Error_Msg_Sloc := Sloc (Parent (Id));
elsif Ekind_In (P, E_Generic_Package, E_Package)
and then not Ignore_Abstract_State
and then Present (Abstract_States (P))
- and then
- not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
+ and then not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
then
return True;
end if;
elsif Ekind_In (P, E_Generic_Package, E_Package)
and then Present (Abstract_States (P))
- and then
- not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
+ and then not Is_Null_State (Node (First_Elmt (Abstract_States (P))))
then
Error_Msg_N
("info: & requires body (non-null abstract state aspect)?Y?", P);
or else
(Is_Generic_Subprogram (E)
and then not Has_Completion (E))
-
then
Error_Msg_Node_2 := E;
Error_Msg_NE
- ("info: & requires body (& requires completion)?Y?",
- E, P);
+ ("info: & requires body (& requires completion)?Y?", E, P);
-- Entity that does not require completion
Decl);
Error_Msg_N ("\Program_Error [<<", Decl);
- elsif
- Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
+ elsif Present
+ (Corresponding_Body (Unit_Declaration_Node (Proc)))
then
Append_Elmt (Proc, Intra_Procs);
end if;
end if;
when E_Constant =>
- if Present (Renamed_Object (E))
- and then Comes_From_Source (Renamed_Object (E))
- then
- Error_Msg_N -- CODEFIX
- ("?u?renamed constant & is not referenced!", E);
- else
- Error_Msg_N -- CODEFIX
- ("?u?constant & is not referenced!", E);
+ if not Has_Pragma_Unreferenced_Objects (Etype (E)) then
+ if Present (Renamed_Object (E))
+ and then Comes_From_Source (Renamed_Object (E))
+ then
+ Error_Msg_N -- CODEFIX
+ ("?u?renamed constant & is not referenced!", E);
+ else
+ Error_Msg_N -- CODEFIX
+ ("?u?constant & is not referenced!", E);
+ end if;
end if;
when E_In_Parameter |
projects / gcc.git / commitdiff