+2017-09-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Find_Role): The Global_Seen flag
+ is now consulted not only for abstract states and variables,
+ but for all kinds of items.
+ (Collect_Subprogram_Inputs_Outputs): Do not process formal
+ generic parameters, because unlike ordinary formal parameters,
+ generic formals only act as input/ outputs if they are explicitly
+ mentioned in a Global contract.
+
+2017-09-07 Yannick Moy <moy@adacore.com>
+
+ * ghost.adb (Check_Ghost_Context): Do not err on ghost code inside
+ predicate procedure. Check predicate pragma/aspect with Ghost entity.
+ * exp_ch6.adb, par-ch6.adb, sem_ch13.adb, sem_prag.adb; Minor
+ reformatting.
+
+2017-09-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb: Move New_Copy_Tree_And_Dimensions to sem_dim
+ (code cleanup);
+ * sem_ch3.adb (Build_Derived_Record_Type):i Call
+ Copy_Dimensions_Of_Components after creating the copy of the
+ record declaration.
+ * sem_dim.ads, sem_dim.adb (Copy_Dimensions_Of_Components): For a
+ derived recor type, copy the dikensions if any of each component
+ of the parent record to the corresponding component declarations
+ of the derived record. These expressions are used among other
+ things as default values in aggregates with box associations.
+ * a-dirval-mingw.adb, g-cgi.adb, gnatcmd.adb, lib-xref.adb,
+ repinfo.adb, sem_attr.adb, sem_ch10.adb, sem_ch6.adb, sem_prag.adb:
+ Minor reformatting.
+
+2017-09-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb: Remove extra space after THEN.
+
+2017-09-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch7.adb (Has_Referencer): For a subprogram renaming,
+ also mark the renamed subprogram as referenced.
+
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* par-ch6.adb (P_Subprogram): Improve error message on null
-- B o d y --
-- (Windows Version) --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2017, 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- --
-- A drive letter may be specified at the beginning
if Name'Length >= 2
- and then Name (Start + 1) = ':'
+ and then Name (Start + 1) = ':'
and then
(Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z')
then
-- there are no tasks.
function Caller_Known_Size
- (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean;
+ (Func_Call : Node_Id;
+ Result_Subt : Entity_Id) return Boolean;
-- True if result subtype is definite, or has a size that does not require
-- secondary stack usage (i.e. no variant part or components whose type
-- depends on discriminants). In particular, untagged types with only
-----------------------
function Caller_Known_Size
- (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean is
+ (Func_Call : Node_Id;
+ Result_Subt : Entity_Id) return Boolean
+ is
begin
- return (Is_Definite_Subtype (Underlying_Type (Result_Subt))
- and then No (Controlling_Argument (Func_Call)))
- or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
+ return
+ (Is_Definite_Subtype (Underlying_Type (Result_Subt))
+ and then No (Controlling_Argument (Func_Call)))
+ or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
end Caller_Known_Size;
--------------------------------
declare
Definite : constant Boolean :=
- Caller_Known_Size (Func_Call, Result_Subt);
+ Caller_Known_Size (Func_Call, Result_Subt);
+
begin
-- Create an access type designating the function's result subtype.
-- We use the type of the original call because it may be a call to
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2010, AdaCore --
+-- Copyright (C) 2001-2017, AdaCore --
-- --
-- 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- --
begin
while K <= S'Last loop
if K + 2 <= S'Last
- and then S (K) = '%'
+ and then S (K) = '%'
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1))
and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2))
then
if Chars (Subp_Id) = Name_uPostconditions then
return True;
+ -- The context is the internally built predicate function,
+ -- which is OK because the real check was done before the
+ -- predicate function was generated.
+
+ elsif Is_Predicate_Function (Subp_Id) then
+ return True;
+
else
Subp_Decl :=
Original_Node (Unit_Declaration_Node (Subp_Id));
return True;
-- An assertion expression pragma is Ghost when it contains a
- -- reference to a Ghost entity (SPARK RM 6.9(10)).
-
- elsif Assertion_Expression_Pragma (Prag_Id) then
+ -- reference to a Ghost entity (SPARK RM 6.9(10)), except for
+ -- predicate pragmas (SPARK RM 6.9(11)).
+ elsif Assertion_Expression_Pragma (Prag_Id)
+ and then Prag_Id /= Pragma_Predicate
+ then
-- Ensure that the assertion policy and the Ghost policy are
-- compatible (SPARK RM 6.9(18)).
return True;
-- A reference to a Ghost entity can appear within an aspect
- -- specification (SPARK RM 6.9(10)).
-
- elsif Nkind (Par) = N_Aspect_Specification then
+ -- specification (SPARK RM 6.9(10)). The precise checking will
+ -- occur when analyzing the corresponding pragma. We make an
+ -- exception for predicate aspects that only allow referencing
+ -- a Ghost entity when the corresponding type declaration is
+ -- Ghost (SPARK RM 6.9(11)).
+
+ elsif Nkind (Par) = N_Aspect_Specification
+ and then not Same_Aspect
+ (Get_Aspect_Id (Par), Aspect_Predicate)
+ then
return True;
elsif Is_OK_Declaration (Par) then
-- report an error indicating that the command is no longer supporting
-- project files.
- if The_Command = Find or else The_Command = Xref then
+ if The_Command = Find or else The_Command = Xref then
declare
- Argv : String_Access;
+ Argv : String_Access;
begin
for Arg_Num in 1 .. Last_Switches.Last loop
Argv := Last_Switches.Table (Arg_Num);
-- original discriminant, which gets the reference.
elsif Ekind (E) = E_In_Parameter
- and then Present (Discriminal_Link (E))
+ and then Present (Discriminal_Link (E))
then
Ent := Discriminal_Link (E);
Set_Referenced (Ent);
if XE.Key.Loc /= No_Location
and then
(XE.Key.Loc /= Crloc
- or else (Prevt = 'm' and then XE.Key.Typ = 'r'))
+ or else (Prevt = 'm' and then XE.Key.Typ = 'r'))
then
Crloc := XE.Key.Loc;
Prevt := XE.Key.Typ;
if Is_Non_Empty_List (Aspects) then
if Func then
- Error_Msg ("aspect specifications must come after "
- & "parenthesized expression",
- Sloc (First (Aspects)));
+ Error_Msg
+ ("aspect specifications must come after "
+ & "parenthesized expression",
+ Sloc (First (Aspects)));
else
- Error_Msg ("aspect specifications must come after "
- & "subprogram specification",
- Sloc (First (Aspects)));
+ Error_Msg
+ ("aspect specifications must come after subprogram "
+ & "specification", Sloc (First (Aspects)));
end if;
end if;
begin
Decl := Parent (E);
while Present (Decl)
- and then Nkind (Decl) /= N_Package_Body
+ and then Nkind (Decl) /= N_Package_Body
and then Nkind (Decl) /= N_Subprogram_Declaration
and then Nkind (Decl) /= N_Subprogram_Body
loop
-- An error message is emitted if the components taking their value from
-- the others choice do not have same type.
- function New_Copy_Tree_And_Copy_Dimensions
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id;
- -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
- -- also copies the dimensions of Source to the returned node.
-
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id);
return Expr;
end Get_Value;
- ---------------------------------------
- -- New_Copy_Tree_And_Copy_Dimensions --
- ---------------------------------------
-
- function New_Copy_Tree_And_Copy_Dimensions
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
- is
- New_Copy : constant Node_Id :=
- New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
-
- begin
- -- Move the dimensions of Source to New_Copy
-
- Copy_Dimensions (Source, New_Copy);
- return New_Copy;
- end New_Copy_Tree_And_Copy_Dimensions;
-
-----------------------------
-- Propagate_Discriminants --
-----------------------------
elsif Nkind (P) = N_Indexed_Component then
if not Is_Entity_Name (Prefix (P))
- or else No (Entity (Prefix (P)))
+ or else No (Entity (Prefix (P)))
or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
then
if Nkind (Prefix (P)) = N_Selected_Component
-- body may not be available, in which case do not try analysis.
if Serious_Errors_Detected > 0
- and then No (Library_Unit (Library_Unit (N)))
+ and then No (Library_Unit (Library_Unit (N)))
then
return;
end if;
-- attempt processing.
if Serious_Errors_Detected > 0
- and then No (Entity (Name (Item)))
+ and then No (Entity (Name (Item)))
then
Set_Entity (Name (Item), Standard_Standard);
end if;
--------------------------------
procedure Resolve_Aspect_Expressions (E : Entity_Id) is
-
function Resolve_Name (N : Node_Id) return Traverse_Result;
-- Verify that all identifiers in the expression, with the exception
-- of references to the current entity, denote visible entities. This
function Resolve_Name (N : Node_Id) return Traverse_Result is
Dummy : Traverse_Result;
+
begin
if Nkind (N) = N_Selected_Component then
if Nkind (Prefix (N)) = N_Identifier
procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name);
+ -- Local variables
+
ASN : Node_Id := First_Rep_Item (E);
-- Start of processing for Resolve_Aspect_Expressions
New_Decl :=
New_Copy_Tree
(Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
+ Copy_Dimensions_Of_Components (Derived_Type);
-- Restore the fields saved prior to the New_Copy_Tree call
-- and compute the stored constraint.
-- or protected interfaces.
elsif Nkind (N) = N_Full_Type_Declaration
- and then Protected_Present (Type_Def)
+ and then Protected_Present (Type_Def)
then
if Limited_Present (Iface_Def)
or else Synchronized_Present (Iface_Def)
procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is
begin
- if not Is_Interface (E) and then E /= Any_Type then
+ if not Is_Interface (E) and then E /= Any_Type then
Error_Msg_NE ("(Ada 2005) & must be an interface", N, E);
end if;
end Diagnose_Interface;
Constrain_Access (Def_Id, S, Related_Nod);
if Expander_Active
- and then Is_Itype (Designated_Type (Def_Id))
+ and then Is_Itype (Designated_Type (Def_Id))
and then Nkind (Related_Nod) = N_Subtype_Declaration
and then not Is_Incomplete_Type (Designated_Type (Def_Id))
then
then
Set_Is_Public (Decl_Id, False);
end if;
+
+ -- For a subprogram renaming, if the entity is referenced,
+ -- then so is the renamed subprogram. But there is an issue
+ -- with generic bodies because instantiations are not done
+ -- yet and, therefore, cannot be scanned for referencers.
+ -- That's why we use an approximation and test that we have
+ -- at least one subprogram referenced by an inlined body
+ -- instead of precisely the entity of this renaming.
+
+ if Nkind (Decl) = N_Subprogram_Renaming_Declaration
+ and then Subprogram_Table.Get_First
+ and then Is_Entity_Name (Name (Decl))
+ and then Present (Entity (Name (Decl)))
+ and then Is_Subprogram (Entity (Name (Decl)))
+ then
+ Subprogram_Table.Set (Entity (Name (Decl)), True);
+ end if;
end if;
Prev (Decl);
end if;
end Copy_Dimensions;
+ -----------------------------------
+ -- Copy_Dimensions_Of_Components --
+ -----------------------------------
+
+ procedure Copy_Dimensions_Of_Components (Rec : Entity_Id) is
+ C : Entity_Id;
+
+ begin
+ C := First_Component (Rec);
+ while Present (C) loop
+ if Nkind (Parent (C)) = N_Component_Declaration then
+ Copy_Dimensions
+ (Expression (Parent (Corresponding_Record_Component (C))),
+ Expression (Parent (C)));
+ end if;
+ Next_Component (C);
+ end loop;
+ end Copy_Dimensions_Of_Components;
+
--------------------------
-- Create_Rational_From --
--------------------------
Remove_Dimensions (From);
end Move_Dimensions;
+ ---------------------------------------
+ -- New_Copy_Tree_And_Copy_Dimensions --
+ ---------------------------------------
+
+ function New_Copy_Tree_And_Copy_Dimensions
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty) return Node_Id
+ is
+ New_Copy : constant Node_Id :=
+ New_Copy_Tree (Source, Map, New_Sloc, New_Scope);
+
+ begin
+ -- Move the dimensions of Source to New_Copy
+
+ Copy_Dimensions (Source, New_Copy);
+ return New_Copy;
+ end New_Copy_Tree_And_Copy_Dimensions;
+
------------
-- Reduce --
------------
-- node that is allowed to contain a dimension (see OK_For_Dimension in
-- body of Sem_Dim).
+ procedure Copy_Dimensions_Of_Components (Rec : Entity_Id);
+ -- Propagate the dimensions of the components of a record type T to the
+ -- components of a record type derived from T. The derivation creates
+ -- a full copy of the type declaration of the parent, and the dimension
+ -- information of individual components must be transferred explicitly.
+
+ function New_Copy_Tree_And_Copy_Dimensions
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty) return Node_Id;
+ -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
+ -- also copies the dimensions of Source to the returned node.
+
function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- If the common base type has a dimension system, verify that two
-- subtypes have the same dimensions. Used for conformance checking.
Item_Is_Output : out Boolean)
is
begin
- Item_Is_Input := False;
- Item_Is_Output := False;
+ case Ekind (Item_Id) is
- -- Abstract states
+ -- Abstract states
- if Ekind (Item_Id) = E_Abstract_State then
+ when E_Abstract_State =>
- -- When pragma Global is present, the mode of the state may be
- -- further constrained by setting a more restrictive mode.
+ -- When pragma Global is present it determines the mode of
+ -- the abstract state.
- if Global_Seen then
- if Appears_In (Subp_Inputs, Item_Id) then
- Item_Is_Input := True;
- end if;
+ if Global_Seen then
+ Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
+ Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
+
+ -- Otherwise the state has a default IN OUT mode, because it
+ -- behaves as a variable.
- if Appears_In (Subp_Outputs, Item_Id) then
+ else
+ Item_Is_Input := True;
Item_Is_Output := True;
end if;
- -- Otherwise the state has a default IN OUT mode
+ -- Constants and IN parameters
- else
- Item_Is_Input := True;
- Item_Is_Output := True;
- end if;
+ when E_Constant
+ | E_Generic_In_Parameter
+ | E_In_Parameter
+ | E_Loop_Parameter
+ =>
+ -- When pragma Global is present it determines the mode
+ -- of constant objects as inputs (and such objects cannot
+ -- appear as outputs in the Global contract).
- -- Constants
+ if Global_Seen then
+ Item_Is_Input := Appears_In (Subp_Inputs, Item_Id);
+ else
+ Item_Is_Input := True;
+ end if;
- elsif Ekind_In (Item_Id, E_Constant,
- E_Loop_Parameter)
- then
- Item_Is_Input := True;
+ Item_Is_Output := False;
- -- Parameters
+ -- Variables and IN OUT parameters
- elsif Ekind_In (Item_Id, E_Generic_In_Parameter,
- E_In_Parameter)
- then
- Item_Is_Input := True;
+ when E_Generic_In_Out_Parameter
+ | E_In_Out_Parameter
+ | E_Variable
+ =>
+ -- When pragma Global is present it determines the mode of
+ -- the object.
- elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter,
- E_In_Out_Parameter)
- then
- Item_Is_Input := True;
- Item_Is_Output := True;
+ if Global_Seen then
- elsif Ekind (Item_Id) = E_Out_Parameter then
- if Scope (Item_Id) = Spec_Id then
+ -- A variable has mode IN when its type is unconstrained
+ -- or tagged because array bounds, discriminants or tags
+ -- can be read.
- -- An OUT parameter of the related subprogram has mode IN
- -- if its type is unconstrained or tagged because array
- -- bounds, discriminants or tags can be read.
+ Item_Is_Input :=
+ Appears_In (Subp_Inputs, Item_Id)
+ or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
- if Is_Unconstrained_Or_Tagged_Item (Item_Id) then
- Item_Is_Input := True;
+ Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
+
+ -- Otherwise the variable has a default IN OUT mode
+
+ else
+ Item_Is_Input := True;
+ Item_Is_Output := True;
end if;
- Item_Is_Output := True;
+ when E_Out_Parameter =>
- -- An OUT parameter of an enclosing subprogram behaves as a
- -- read-write variable in which case the mode is IN OUT.
+ -- An OUT parameter of the related subprogram; it cannot
+ -- appear in Global.
- else
- Item_Is_Input := True;
- Item_Is_Output := True;
- end if;
+ if Scope (Item_Id) = Spec_Id then
- -- Protected types
+ -- The parameter has mode IN if its type is unconstrained
+ -- or tagged because array bounds, discriminants or tags
+ -- can be read.
- elsif Ekind (Item_Id) = E_Protected_Type then
+ Item_Is_Input :=
+ Is_Unconstrained_Or_Tagged_Item (Item_Id);
- -- A protected type acts as a formal parameter of mode IN when
- -- it applies to a protected function.
+ Item_Is_Output := True;
- if Ekind (Spec_Id) = E_Function then
- Item_Is_Input := True;
+ -- An OUT parameter of an enclosing subprogram; it can
+ -- appear in Global and behaves as a read-write variable.
- -- Otherwise the protected type acts as a formal of mode IN OUT
+ else
+ -- When pragma Global is present it determines the mode
+ -- of the object.
- else
- Item_Is_Input := True;
- Item_Is_Output := True;
- end if;
+ if Global_Seen then
- -- Task types
+ -- A variable has mode IN when its type is
+ -- unconstrained or tagged because array
+ -- bounds, discriminants or tags can be read.
- elsif Ekind (Item_Id) = E_Task_Type then
- Item_Is_Input := True;
- Item_Is_Output := True;
+ Item_Is_Input :=
+ Appears_In (Subp_Inputs, Item_Id)
+ or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
- -- Variable case
+ Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
- else pragma Assert (Ekind (Item_Id) = E_Variable);
+ -- Otherwise the variable has a default IN OUT mode
- -- When pragma Global is present, the mode of the variable may
- -- be further constrained by setting a more restrictive mode.
+ else
+ Item_Is_Input := True;
+ Item_Is_Output := True;
+ end if;
+ end if;
- if Global_Seen then
+ -- Protected types
- -- A variable has mode IN when its type is unconstrained or
- -- tagged because array bounds, discriminants or tags can be
- -- read.
+ when E_Protected_Type =>
+ if Global_Seen then
- if Appears_In (Subp_Inputs, Item_Id)
- or else Is_Unconstrained_Or_Tagged_Item (Item_Id)
- then
- Item_Is_Input := True;
+ -- A variable has mode IN when its type is unconstrained
+ -- or tagged because array bounds, discriminants or tags
+ -- can be read.
+
+ Item_Is_Input :=
+ Appears_In (Subp_Inputs, Item_Id)
+ or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
+
+ Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
+
+ else
+ -- A protected type acts as a formal parameter of mode IN
+ -- when it applies to a protected function.
+
+ if Ekind (Spec_Id) = E_Function then
+ Item_Is_Input := True;
+ Item_Is_Output := False;
+
+ -- Otherwise the protected type acts as a formal of mode
+ -- IN OUT.
+
+ else
+ Item_Is_Input := True;
+ Item_Is_Output := True;
+ end if;
end if;
- if Appears_In (Subp_Outputs, Item_Id) then
+ -- Task types
+
+ when E_Task_Type =>
+
+ -- When pragma Global is present it determines the mode of
+ -- the object.
+
+ if Global_Seen then
+ Item_Is_Input :=
+ Appears_In (Subp_Inputs, Item_Id)
+ or else Is_Unconstrained_Or_Tagged_Item (Item_Id);
+
+ Item_Is_Output := Appears_In (Subp_Outputs, Item_Id);
+
+ -- Otherwise task types act as IN OUT parameters
+
+ else
+ Item_Is_Input := True;
Item_Is_Output := True;
end if;
- -- Otherwise the variable has a default IN OUT mode
-
- else
- Item_Is_Input := True;
- Item_Is_Output := True;
- end if;
- end if;
+ when others =>
+ raise Program_Error;
+ end case;
end Find_Role;
----------------
-- pragma is inserted in its declarative part.
elsif From_Aspect_Specification (N)
- and then Ent = Current_Scope
+ and then Ent = Current_Scope
and then
Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body
then
if Nkind (Clause) = N_Null then
null;
- -- A dependency cause appears as component association
+ -- A dependency clause appears as component association
elsif Nkind (Clause) = N_Component_Association then
Collect_Dependency_Item
Subp_Decl := Unit_Declaration_Node (Subp_Id);
Spec_Id := Unique_Defining_Entity (Subp_Decl);
- -- Process all [generic] formal parameters
+ -- Process all formal parameters
Formal := First_Entity (Spec_Id);
while Present (Formal) loop
- if Ekind_In (Formal, E_Generic_In_Parameter,
- E_In_Out_Parameter,
- E_In_Parameter)
- then
+ if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then
Append_New_Elmt (Formal, Subp_Inputs);
end if;
- if Ekind_In (Formal, E_Generic_In_Out_Parameter,
- E_In_Out_Parameter,
- E_Out_Parameter)
- then
+ if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
Append_New_Elmt (Formal, Subp_Outputs);
-- Out parameters can act as inputs when the related type is
if Inside_A_Generic then
Gen := Current_Scope;
- while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
+ while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop
Gen := Scope (Gen);
end loop;
projects / gcc.git / commitdiff