2014-01-22 Robert Dewar <dewar@adacore.com>
+ * sem_aux.adb, sem_aux.ads, sem_ch3.adb (Has_Unconstrained_Elements):
+ Moved to sem_aux.adb.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * vms_data.ads: Minor reformatting.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * debug.adb: Document messages affected by -gnatd.E including
+ the new ones that relate to late definition of equality.
+ * sem_ch6.adb (Check_Untagged_Equality): In Ada 2012 mode, if
+ debug flag -gnatd.E is set, then generate warnings rather than
+ errors.
+ (Check_Untagged_Equality): In earlier versions of Ada,
+ generate warnings if Warn_On_Ada_2012_Incompatibility flag is set.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Usage_Error): Output additional messages for
+ unconstrained OUT parameters lacking an input dependency.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch4.adb: Minor reformatting.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
+ * restrict.ads: Minor reformatting.
+ * sem_res.adb (Resolve_Call): Check for SPARK_05 restriction that
+ forbids a call from within a subprogram to the same subprogram.
+
+2014-01-22 Thomas Quinot <quinot@adacore.com>
+
+ * a-stream.ads (Read_SEA, Write_SEA): New subprograms, optimized
+ stream attributes for Stream_Element_Array.
+ * a-stream.adb (Read_SEA, Write_SEA): Bodies for the above.
+ * rtsfind.adb (Check_CRT): Do not reject a reference to an entity
+ defined in the current scope.
+
+2014-01-22 Robert Dewar <dewar@adacore.com>
+
* debug.adb, exp_ch4.adb, erroutc.adb: Minor reformatting.
2014-01-22 Thomas Quinot <quinot@adacore.com>
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R E A M S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+
+package body Ada.Streams is
+
+ --------------
+ -- Read_SEA --
+ --------------
+
+ procedure Read_SEA
+ (S : access Root_Stream_Type'Class;
+ V : out Stream_Element_Array)
+ is
+ Last : Stream_Element_Offset;
+ begin
+ Read (S.all, V, Last);
+ if Last /= V'Last then
+ raise Ada.IO_Exceptions.End_Error;
+ end if;
+ end Read_SEA;
+
+ ---------------
+ -- Write_SEA --
+ ---------------
+
+ procedure Write_SEA
+ (S : access Root_Stream_Type'Class;
+ V : Stream_Element_Array)
+ is
+ begin
+ Write (S.all, V);
+ end Write_SEA;
+
+end Ada.Streams;
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
--- A D A . S T R E A M S --
+-- A D A . S T R E A M S --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
type Root_Stream_Type is abstract tagged limited null record;
+ -- Stream attributes for Stream_Element_Array: trivially call the
+ -- corresponding stream primitive for the whole array, instead of doing
+ -- so element by element.
+
+ procedure Read_SEA
+ (S : access Root_Stream_Type'Class;
+ V : out Stream_Element_Array);
+
+ procedure Write_SEA
+ (S : access Root_Stream_Type'Class;
+ V : Stream_Element_Array);
+
+ for Stream_Element_Array'Read use Read_SEA;
+ for Stream_Element_Array'Write use Write_SEA;
+
end Ada.Streams;
-- d.E Turn selected errors into warnings. This debug switch causes a
-- specific set of error messages into warnings. Setting this switch
- -- causes Opt.Error_To_Warning to be set to True. Right now the only
- -- error affected is the case of overlapping subprogram parameters
- -- which has become illegal in Ada 2012, but only generates a warning
- -- in earlier versions of Ada.
+ -- causes Opt.Error_To_Warning to be set to True. The intention is
+ -- that this be used for messages representing upwards incompatible
+ -- changes to Ada 2012 that cause previously correct programs to be
+ -- treated as illegal now. The following cases are affected:
+ --
+ -- Errors relating to overlapping subprogram parameters for cases
+ -- other than IN OUT parameters to functions.
+ --
+ -- Errors relating to the new rules about not defining equality
+ -- too late so that composition of equality can be assured.
-- d.F Sets GNATprove_Mode to True. This allows debugging the frontend in
-- the special mode used by GNATprove.
(Msg : String;
N : Node_Id;
Force : Boolean := False);
- -- Node N represents a construct not allowed in formal mode. If this is
+ -- Node N represents a construct not allowed in SPARK_05 mode. If this is
-- a source node, or if the restriction is forced (Force = True), and
-- the SPARK_05 restriction is set, then an error is issued on N. Msg
-- is appended to the restriction failure message.
-- Entity is available
else
- -- If in No_Run_Time mode and entity is not in one of the
- -- specially permitted units, raise the exception.
+ -- If in No_Run_Time mode and entity is neither in the current unit
+ -- nor in one of the specially permitted units, raise the exception.
if No_Run_Time_Mode
and then not OK_No_Run_Time_Unit (U_Id)
+
+ -- If the entity being referenced is defined in the current scope,
+ -- using it is always fine as such usage can never introduce any
+ -- dependency on an additional unit.
+ -- Why do we need to do this test ???
+
+ and then Scope (Eid) /= Current_Scope
then
Entity_Not_Defined (E);
raise RE_Not_Available;
return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Pragma;
+ --------------------------------
+ -- Has_Unconstrained_Elements --
+ --------------------------------
+
+ function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
+ U_T : constant Entity_Id := Underlying_Type (T);
+ begin
+ if No (U_T) then
+ return False;
+ elsif Is_Record_Type (U_T) then
+ return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
+ elsif Is_Array_Type (U_T) then
+ return Has_Unconstrained_Elements (Component_Type (U_T));
+ else
+ return False;
+ end if;
+ end Has_Unconstrained_Elements;
+
---------------------
-- In_Generic_Body --
---------------------
-- the given names then True is returned, otherwise False indicates that no
-- matching entry was found.
+ function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
+ -- True if T has discriminants and is unconstrained, or is an array type
+ -- whose element type Has_Unconstrained_Elements.
+
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
-- or a variant record type is encountered, Check_Restrictions is called
-- indicating the count is unknown.
- function Has_Unconstrained_Elements (T : Entity_Id) return Boolean;
- -- True if T has discriminants and is unconstrained, or is an array
- -- type whose element type Has_Unconstrained_Elements. Shouldn't this
- -- be in sem_util???
-
-----------------
-- Count_Tasks --
-----------------
end if;
end Count_Tasks;
- --------------------------------
- -- Has_Unconstrained_Elements --
- --------------------------------
-
- function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is
- U_T : constant Entity_Id := Underlying_Type (T);
- begin
- if No (U_T) then
- return False;
- elsif Is_Record_Type (U_T) then
- return Has_Discriminants (U_T) and then not Is_Constrained (U_T);
- elsif Is_Array_Type (U_T) then
- return Has_Unconstrained_Elements (Component_Type (U_T));
- else
- return False;
- end if;
- end Has_Unconstrained_Elements;
-
-- Start of processing for Analyze_Object_Declaration
begin
and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
and then
(not Name_Denotes_Function
- or else Nkind (N) = N_Procedure_Call_Statement
- or else
- (Nkind (Parent (N)) /= N_Explicit_Dereference
- and then Is_Entity_Name (Nam)
- and then No (First_Formal (Entity (Nam)))
- and then not
- Is_Array_Type (Etype (Designated_Type (Etype (Nam))))
- and then Present (Actuals)))
+ or else Nkind (N) = N_Procedure_Call_Statement
+ or else
+ (Nkind (Parent (N)) /= N_Explicit_Dereference
+ and then Is_Entity_Name (Nam)
+ and then No (First_Formal (Entity (Nam)))
+ and then not
+ Is_Array_Type (Etype (Designated_Type (Etype (Nam))))
+ and then Present (Actuals)))
then
Nam_Ent := Designated_Type (Etype (Nam));
Insert_Explicit_Dereference (Nam);
-- must appear before the type is frozen, and have the same visibility as
-- that of the type. This procedure checks that this rule is met, and
-- otherwise emits an error on the subprogram declaration and a warning
- -- on the earlier freeze point if it is easy to locate.
+ -- on the earlier freeze point if it is easy to locate. In Ada 2012 mode,
+ -- this routine outputs errors (or warnings if -gnatd.E is set). In earlier
+ -- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility
+ -- is set, otherwise the call has no effect.
procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible
Obj_Decl : Node_Id;
begin
- if Nkind (Decl) = N_Subprogram_Declaration
- and then Is_Record_Type (Typ)
- and then not Is_Tagged_Type (Typ)
+ -- This check applies only if we have a subprogram declaration with a
+ -- non-tagged record type.
+
+ if Nkind (Decl) /= N_Subprogram_Declaration
+ or else not Is_Record_Type (Typ)
+ or else Is_Tagged_Type (Typ)
then
- -- If the type is not declared in a package, or if we are in the
- -- body of the package or in some other scope, the new operation is
- -- not primitive, and therefore legal, though suspicious. If the
- -- type is a generic actual (sub)type, the operation is not primitive
- -- either because the base type is declared elsewhere.
-
- if Is_Frozen (Typ) then
- if Ekind (Scope (Typ)) /= E_Package
- or else Scope (Typ) /= Current_Scope
- then
- null;
+ return;
+ end if;
- elsif Is_Generic_Actual_Type (Typ) then
- null;
+ -- In Ada 2012 case, we will output errors or warnings depending on
+ -- the setting of debug flag -gnatd.E.
+
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_Warn := Debug_Flag_Dot_EE;
+
+ -- In earlier versions of Ada, nothing to do unless we are warning on
+ -- Ada 2012 incompatibilities (Warn_On_Ada_2012_Incompatibility set).
+
+ else
+ if not Warn_On_Ada_2012_Compatibility then
+ return;
+ end if;
+ end if;
+
+ -- Cases where the type has already been frozen
- elsif In_Package_Body (Scope (Typ)) then
+ if Is_Frozen (Typ) then
+
+ -- If the type is not declared in a package, or if we are in the body
+ -- of the package or in some other scope, the new operation is not
+ -- primitive, and therefore legal, though suspicious. Should we
+ -- generate a warning in this case ???
+
+ if Ekind (Scope (Typ)) /= E_Package
+ or else Scope (Typ) /= Current_Scope
+ then
+ return;
+
+ -- If the type is a generic actual (sub)type, the operation is not
+ -- primitive either because the base type is declared elsewhere.
+
+ elsif Is_Generic_Actual_Type (Typ) then
+ return;
+
+ -- Here we have a definite error of declaration after freezing
+
+ else
+ if Ada_Version >= Ada_2012 then
Error_Msg_NE
- ("equality operator must be declared "
- & "before type& is frozen", Eq_Op, Typ);
- Error_Msg_N
- ("\move declaration to package spec", Eq_Op);
+ ("equality operator must be declared before type& is "
+ & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ);
+
+ -- In Ada 2012 mode with error turned to warning, output one
+ -- more warning to warn that the equality operation may not
+ -- compose. This is the consequence of ignoring the error.
+
+ if Error_Msg_Warn then
+ Error_Msg_N ("\equality operation may not compose??", Eq_Op);
+ end if;
else
Error_Msg_NE
- ("equality operator must be declared "
- & "before type& is frozen", Eq_Op, Typ);
+ ("equality operator must be declared before type& is "
+ & "frozen (RM 4.5.2 (9.8)) (Ada 2012)?y?", Eq_Op, Typ);
+ end if;
+ -- If we are in the package body, we could just move the
+ -- declaration to the package spec, so add a message saying that.
+
+ if In_Package_Body (Scope (Typ)) then
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("\move declaration to package spec<<", Eq_Op);
+ else
+ Error_Msg_N
+ ("\move declaration to package spec (Ada 2012)?y?", Eq_Op);
+ end if;
+
+ -- Otherwise try to find the freezing point
+
+ else
Obj_Decl := Next (Parent (Typ));
while Present (Obj_Decl) and then Obj_Decl /= Decl loop
if Nkind (Obj_Decl) = N_Object_Declaration
and then Etype (Defining_Identifier (Obj_Decl)) = Typ
then
- Error_Msg_NE
- ("type& is frozen by declaration??", Obj_Decl, Typ);
- Error_Msg_N
- ("\an equality operator cannot be declared after this "
- & "point (RM 4.5.2 (9.8)) (Ada 2012))??", Obj_Decl);
+ -- Freezing point, output warnings
+
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_NE
+ ("type& is frozen by declaration??", Obj_Decl, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after "
+ & "this point??",
+ Obj_Decl);
+ else
+ Error_Msg_NE
+ ("type& is frozen by declaration (Ada 2012)?y?",
+ Obj_Decl, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after "
+ & "this point (Ada 2012)?y?",
+ Obj_Decl);
+ end if;
+
exit;
end if;
Next (Obj_Decl);
end loop;
end if;
+ end if;
- elsif not In_Same_List (Parent (Typ), Decl)
- and then not Is_Limited_Type (Typ)
- then
+ -- Here if type is not frozen yet. It is illegal to have a primitive
+ -- equality declared in the private part if the type is visible.
- -- This makes it illegal to have a primitive equality declared in
- -- the private part if the type is visible.
+ elsif not In_Same_List (Parent (Typ), Decl)
+ and then not Is_Limited_Type (Typ)
+ then
+ -- Shouldn't we give an RM reference here???
- Error_Msg_N ("equality operator appears too late", Eq_Op);
+ if Ada_Version >= Ada_2012 then
+ Error_Msg_N
+ ("equality operator appears too late<<", Eq_Op);
+ else
+ Error_Msg_N
+ ("equality operator appears too late (Ada 2012)?y?", Eq_Op);
end if;
+
+ -- No error detected
+
+ else
+ return;
end if;
end Check_Untagged_Equality;
and then not Is_Dispatching_Operation (S)
then
Make_Inequality_Operator (S);
-
- if Ada_Version >= Ada_2012 then
- Check_Untagged_Equality (S);
- end if;
+ Check_Untagged_Equality (S);
end if;
end New_Overloaded_Entity;
-----------------
procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is
+ Typ : constant Entity_Id := Etype (Item_Id);
+
begin
+ -- Input case
+
if Is_Input then
Error_Msg_NE
("item & must appear in at least one input list of aspect "
& "Depends", Item, Item_Id);
+
+ -- Case of OUT parameter for which Is_Input is set
+
+ if Nkind (Item) = N_Defining_Identifier
+ and then Ekind (Item) = E_Out_Parameter
+ then
+ -- One case is an unconstrained array where the bounds
+ -- must be read, if we have this case, output a message
+ -- indicating why the OUT parameter is read.
+
+ if Is_Array_Type (Typ)
+ and then not Is_Constrained (Typ)
+ then
+ Error_Msg_NE
+ ("\& is an unconstrained array type, so bounds must be "
+ & "read", Item, Typ);
+
+ -- Another case is an unconstrained discriminated record
+ -- type where the constrained flag must be read (and if
+ -- set, the discriminants). Again output a message.
+
+ elsif Is_Record_Type (Typ)
+ and then Has_Discriminants (Typ)
+ and then not Is_Constrained (Typ)
+ then
+ Error_Msg_NE
+ ("\& is an unconstrained discriminated record type",
+ Item, Typ);
+ Error_Msg_N
+ ("\constrained flag and possible discriminants must be "
+ & "read", Item);
+
+ -- Not clear if there are other cases. Anyway, we will
+ -- simply ignore any other cases.
+
+ else
+ null;
+ end if;
+ end if;
+
+ -- Output case
+
else
Error_Msg_NE
("item & must appear in exactly one output list of aspect "
is
Subp_Alias : constant Entity_Id := Alias (S);
begin
- return S = E
- or else (Present (Subp_Alias) and then Subp_Alias = E);
+ return S = E or else (Present (Subp_Alias) and then Subp_Alias = E);
end Same_Or_Aliased_Subprograms;
-- Start of processing for Resolve_Call
if Comes_From_Source (N) then
Scop := Current_Scope;
+ -- Check violation of SPARK_05 restriction which does not permit
+ -- a subprogram body to contain a call to the subprogram directly.
+
+ if Restriction_Check_Required (SPARK_05)
+ and then Same_Or_Aliased_Subprograms (Nam, Scop)
+ then
+ Check_SPARK_Restriction
+ ("subprogram may not contain direct call to itself", N);
+ end if;
+
-- Issue warning for possible infinite recursion in the absence
-- of the No_Recursion restriction.
-- switch -gnat??. See below for list of these
-- equivalent switch names.
--
- -- NOTAG_WARNINGS Turns off warning tag output (default setting).
+ -- NOTAG_WARNINGS Turns off warning tag output (default
+ -- setting).
--
-- The remaining entries control individual warning categories. If one
-- of these options is preceded by NO (e.g. NOAVOID_GAPS), then the
projects / platform / upstream / linaro-gcc.git / commitdiff