2017-09-07 Yannick Moy <moy@adacore.com>
* a-exetim-mingw.ads: Add contract Global=>null
on all operations that are modeled as having no read or write
of global variables in SPARK.
2017-09-07 Raphael Amiard <amiard@adacore.com>
* a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added
to Hmaps.Generic_Ops.
* a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in
cursors.
* a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in
cursors.
* a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper
position in cursors.
2017-09-07 Javier Miranda <miranda@adacore.com>
* sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to
allow disabling the generation of implicit pragma Elaborate_All
on task bodies.
2017-09-07 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_Tags): Avoid suffix counter
in the external name of the elaboration flag. Required to fix
the regressions introduced by the initial version of this patch.
2017-09-07 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): Do not
insert an explicit conversion to force the displacement of the
"this" pointer to reference the secondary dispatch table in the
case where the return statement is returning a raise expression,
as in "return raise ...".
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* sem_disp.adb (Is_User_Defined_Equality): Removed procedure.
* sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied
procedure from sem_disp.adb.
* sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package
with Unit.
* sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to
return the instantiation node for subprograms. Update references
to Get_Unit_Instantiation_Node.
* sem_ch7.adb (Install_Parent_Private_Declarations): update
reference to Get_Unit_Instantiation_Node.
* exp_dist.adb (Build_Package_Stubs): update reference to
Get_Unit_Instantiation_Node.
* sem_ch9.adb: minor typo in comment.
* lib-xref-spark_specific.adb
(Traverse_Declaration_Or_Statement): traverse into task type
definition.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
to handle properly various cases of type conversions where the
target type and/or the expression carry dimension information.
(Dimension_System_Root); If a subtype carries dimension
information, obtain the source parent type that carries the
Dimension aspect.
2017-09-07 Dmitriy Anisimkov <anisimko@adacore.com>
* g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained):
If the prefix is a reference to an object, rewrite it as an
explicit dereference, as required by 3.7.2 (2) and as is done
with most other attributes whose prefix is an access value.
2017-09-07 Bob Duff <duff@adacore.com>
* par-ch13.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends aspect.
* par-ch2.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends pragma.
* scans.ads: Fix documentation of Inside_Depends flag.
* styleg.adb, styleg.ads: Minor reformatting and comment fixes.
2017-09-07 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Insert_Actions_In_Scope_Around):
Account for the case where the are no lists to insert, but the
secondary stack still requires management.
* a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb,
comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb,
lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb,
sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb:
Minor reformatting.
From-SVN: r251842
+2017-09-07 Yannick Moy <moy@adacore.com>
+
+ * a-exetim-mingw.ads: Add contract Global=>null
+ on all operations that are modeled as having no read or write
+ of global variables in SPARK.
+
+2017-09-07 Raphael Amiard <amiard@adacore.com>
+
+ * a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added
+ to Hmaps.Generic_Ops.
+ * a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in
+ cursors.
+ * a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in
+ cursors.
+ * a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper
+ position in cursors.
+
+2017-09-07 Javier Miranda <miranda@adacore.com>
+
+ * sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to
+ allow disabling the generation of implicit pragma Elaborate_All
+ on task bodies.
+
+2017-09-07 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_Tags): Avoid suffix counter
+ in the external name of the elaboration flag. Required to fix
+ the regressions introduced by the initial version of this patch.
+
+2017-09-07 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Analyze_Function_Return): Do not
+ insert an explicit conversion to force the displacement of the
+ "this" pointer to reference the secondary dispatch table in the
+ case where the return statement is returning a raise expression,
+ as in "return raise ...".
+
+2017-09-07 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_disp.adb (Is_User_Defined_Equality): Removed procedure.
+ * sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied
+ procedure from sem_disp.adb.
+ * sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package
+ with Unit.
+ * sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to
+ return the instantiation node for subprograms. Update references
+ to Get_Unit_Instantiation_Node.
+ * sem_ch7.adb (Install_Parent_Private_Declarations): update
+ reference to Get_Unit_Instantiation_Node.
+ * exp_dist.adb (Build_Package_Stubs): update reference to
+ Get_Unit_Instantiation_Node.
+ * sem_ch9.adb: minor typo in comment.
+ * lib-xref-spark_specific.adb
+ (Traverse_Declaration_Or_Statement): traverse into task type
+ definition.
+
+2017-09-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
+ to handle properly various cases of type conversions where the
+ target type and/or the expression carry dimension information.
+ (Dimension_System_Root); If a subtype carries dimension
+ information, obtain the source parent type that carries the
+ Dimension aspect.
+
+2017-09-07 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine.
+
+2017-09-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained):
+ If the prefix is a reference to an object, rewrite it as an
+ explicit dereference, as required by 3.7.2 (2) and as is done
+ with most other attributes whose prefix is an access value.
+
+2017-09-07 Bob Duff <duff@adacore.com>
+
+ * par-ch13.adb: Set the Inside_Depends flag if we are inside a
+ Refined_Depends aspect.
+ * par-ch2.adb: Set the Inside_Depends flag if we are inside a
+ Refined_Depends pragma.
+ * scans.ads: Fix documentation of Inside_Depends flag.
+ * styleg.adb, styleg.ads: Minor reformatting and comment fixes.
+
+2017-09-07 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Insert_Actions_In_Scope_Around):
+ Account for the case where the are no lists to insert, but the
+ secondary stack still requires management.
+ * a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb,
+ comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb,
+ lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb,
+ sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb:
+ Minor reformatting.
+
2017-09-07 Vincent Celier <celier@adacore.com>
* clean.adb: Do not get the target parameters before calling
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
+ procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type);
+
+ -------------
+ -- Wrapper --
+ -------------
+
+ procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is
+ begin
+ Process (Node);
+ end Wrapper;
+
+ procedure Internal_With_Pos is
+ new Generic_Iteration_With_Position (Wrapper);
+
+ -- Start of processing for Generic_Iteration
+
+ begin
+ Internal_With_Pos (HT);
+ end Generic_Iteration;
+
+ -------------------------------------
+ -- Generic_Iteration_With_Position --
+ -------------------------------------
+
+ procedure Generic_Iteration_With_Position
+ (HT : Hash_Table_Type)
+ is
Node : Node_Access;
begin
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= null loop
- Process (Node);
+ Process (Node, Indx);
Node := Next (Node);
end loop;
end loop;
- end Generic_Iteration;
+ end Generic_Iteration_With_Position;
------------------
-- Generic_Read --
-- can implement efficient iterators.
generic
+ with procedure Process (Node : Node_Access; Position : Hash_Type);
+ procedure Generic_Iteration_With_Position (HT : Hash_Table_Type);
+ -- Calls Process for each node in hash table HT
+
+ generic
with procedure Process (Node : Node_Access);
procedure Generic_Iteration (HT : Hash_Table_Type);
-- Calls Process for each node in hash table HT
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
- procedure Process_Node (Node : Node_Access);
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
procedure Local_Iterate is
- new HT_Ops.Generic_Iteration (Process_Node);
+ new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
- procedure Process_Node (Node : Node_Access) is
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
- Process
- (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
+ Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
- procedure Process_Node (Node : Node_Access);
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
- procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
+ procedure Local_Iterate is
+ new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
- procedure Process_Node (Node : Node_Access) is
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
- Process
- (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
+ Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
(Container : Set;
Process : not null access procedure (Position : Cursor))
is
- procedure Process_Node (Node : Node_Access);
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
procedure Iterate is
- new HT_Ops.Generic_Iteration (Process_Node);
+ new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
- procedure Process_Node (Node : Node_Access) is
+ procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
- Process
- (Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
+ Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2017, 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 --
function "-"
(Left : CPU_Time;
- Right : CPU_Time) return Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ with
+ Global => null;
function "<" (Left, Right : CPU_Time) return Boolean with
Global => null;
Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T);
Iface_Table : constant Interface_Data_Ptr :=
To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
+
begin
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
if Is_Static or else Offset_Value = 0 then
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
- Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
+ Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
Offset_Value;
else
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
- Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
+ Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
Offset_Func;
end if;
when N_Package_Body =>
Unit_Name := Corresponding_Spec (Main);
- when N_Package_Renaming_Declaration
- | N_Package_Instantiation
+ when N_Package_Instantiation
+ | N_Package_Renaming_Declaration
=>
Unit_Name := Defining_Unit_Name (Main);
-- d.v
-- d.w Do not check for infinite loops
-- d.x No exception handlers
- -- d.y
+ -- d.y Disable implicit pragma Elaborate_All on task bodies
-- d.z Restore previous support for frontend handling of Inline_Always
-- d.A Read/write Aspect_Specifications hash table to tree
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
+ -- d.y Disable implicit pragma Elaborate_All on task bodies. When a task
+ -- body calls a procedure in the same package, and that procedure
+ -- calls a procedure in another package, the static elaboration
+ -- machinery adds an implicit Elaborate_All on the other package. This
+ -- switch disables the addition of the implicit pragma in such cases.
+ --
-- d.z Restore previous front-end support for Inline_Always. In default
-- mode, for targets that use the GCC back end, Inline_Always is
-- handled by the back end. Use of this switch restores the previous
function Access_Disp_Table (Id : E) return L is
begin
- pragma Assert (Ekind_In (Id, E_Record_Type,
- E_Record_Type_With_Private,
- E_Record_Subtype));
+ pragma Assert (Ekind_In (Id, E_Record_Subtype,
+ E_Record_Type,
+ E_Record_Type_With_Private));
return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Access_Disp_Table_Elab_Flag (Id : E) return E is
begin
- pragma Assert (Ekind_In (Id, E_Record_Type,
- E_Record_Type_With_Private,
- E_Record_Subtype));
+ pragma Assert (Ekind_In (Id, E_Record_Subtype,
+ E_Record_Type,
+ E_Record_Type_With_Private));
return Node30 (Implementation_Base_Type (Id));
end Access_Disp_Table_Elab_Flag;
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
- (Typ => Base_Type (Typ),
- Target => Target,
- Stmts_List => Assign,
+ (Typ => Base_Type (Typ),
+ Target => Target,
+ Stmts_List => Assign,
Init_Tags_List => Assign);
end if;
end if;
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
- (Typ => Base_Type (Typ),
- Target => Target,
- Stmts_List => L,
+ (Typ => Base_Type (Typ),
+ Target => Target,
+ Stmts_List => L,
Init_Tags_List => L);
end if;
end if;
New_Occurrence_Of
(Extra_Constrained (Formal_Ent), Sloc (N)));
+ -- If the prefix is an access to object, the attribute applies to
+ -- the designated object, so rewrite with an explicit dereference.
+
+ elsif Is_Access_Type (Etype (Pref))
+ and then
+ (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
+ then
+ Rewrite (Pref,
+ Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
+ Analyze_And_Resolve (N, Standard_Boolean);
+ return;
+
-- For variables with a Extra_Constrained field, we use the
-- corresponding entity.
Append_To (Elab_Sec_DT_Stmts_List,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Expression =>
New_Occurrence_Of (Standard_False, Loc)));
- Prepend_List_To (Body_Stmts,
- New_List (
- Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
- Then_Statements => Init_Tags_List),
+ Prepend_List_To (Body_Stmts, New_List (
+ Make_If_Statement (Loc,
+ Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Then_Statements => Init_Tags_List),
Make_If_Statement (Loc,
- Condition =>
+ Condition =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Then_Statements => Elab_Sec_DT_Stmts_List)));
else
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
- Condition => New_Occurrence_Of (Set_Tag, Loc),
+ Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
end if;
-- Start of processing for Insert_Actions_In_Scope_Around
begin
- if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then
+ -- Nothing to do if the scope does not manage the secondary stack or
+ -- does not contain meaninful actions for insertion.
+
+ if not Manage_SS
+ and then No (Act_Before)
+ and then No (Act_After)
+ and then No (Act_Cleanup)
+ then
return;
end if;
if Elab_Flag_Needed (Typ) then
Set_Access_Disp_Table_Elab_Flag (Typ,
Make_Defining_Identifier (Loc,
- New_External_Name (Tname, 'F', Suffix_Index => -1)));
+ Chars => New_External_Name (Tname, 'F')));
Append_To (Result,
Make_Object_Declaration (Loc,
or else
(Is_Generic_Instance (Pkg_Ent)
and then Comes_From_Source
- (Get_Package_Instantiation_Node (Pkg_Ent)))
+ (Get_Unit_Instantiation_Node (Pkg_Ent)))
then
Visit_Nested_Pkg (Decl);
end if;
return Stream_Access (S);
end Stream;
+ ------------
+ -- To_Ada --
+ ------------
+
+ function To_Ada (Fd : Integer) return Socket_Type is
+ begin
+ return Socket_Type (Fd);
+ end To_Ada;
+
----------
-- To_C --
----------
function Image (Socket : Socket_Type) return String;
-- Return a printable string for Socket
- function To_C (Socket : Socket_Type) return Integer;
+ function To_Ada (Fd : Integer) return Socket_Type with Inline;
+ -- Convert a file descriptor to Socket_Type. This is useful when a socket
+ -- file descriptor is obtained from an external library call.
+
+ function To_C (Socket : Socket_Type) return Integer with Inline;
-- Return a file descriptor to be used by external subprograms. This is
-- useful for C functions that are not yet interfaced in this package.
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-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- --
when N_Protected_Type_Declaration =>
Traverse_Visible_And_Private_Parts (Protected_Definition (N));
- when N_Task_Definition =>
- Traverse_Visible_And_Private_Parts (N);
+ when N_Task_Type_Declaration =>
+
+ -- Task type definition is optional (unlike protected type
+ -- definition, which is mandatory).
+
+ declare
+ Task_Def : constant Node_Id := Task_Definition (N);
+ begin
+ if Present (Task_Def) then
+ Traverse_Visible_And_Private_Parts (Task_Def);
+ end if;
+ end;
when N_Task_Body =>
Traverse_Task_Body (N);
-- Comment needed here for special SPARK code ???
if GNATprove_Mode then
- -- Ignore reference to an entity that is a Part_Of single
+
+ -- Ignore references to an entity which is a Part_Of single
-- concurrent object. Ideally we would prefer to add it as a
-- reference to the corresponding concurrent type, but it is quite
-- difficult (as such references are not currently added even for)
-- reads/writes of private protected components) and not worth the
-- effort.
+
if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable)
and then Present (Encapsulating_State (Ent))
and then Is_Single_Concurrent_Object (Encapsulating_State (Ent))
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
end if;
end if;
- -- Note if inside Depends aspect
+ -- Note if inside Depends or Refined_Depends aspect
- if A_Id = Aspect_Depends then
+ if A_Id = Aspect_Depends
+ or else A_Id = Aspect_Refined_Depends
+ then
Inside_Depends := True;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Set global to indicate if we are within a Depends pragma
- if Chars (Ident_Node) = Name_Depends then
+ if Chars (Ident_Node) = Name_Depends
+ or else Chars (Ident_Node) = Name_Refined_Depends
+ then
Inside_Depends := True;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- about the case of Wide_Wide_Characters???
Inside_Depends : Boolean := False;
- -- True while parsing the argument of a Depends pragma or aspect (used to
- -- allow/require non-standard style rules for =>+ with -gnatyt).
+ -- True while parsing the argument of a Depends or Refined_Depends pragma
+ -- or aspect. Used to allow/require nonstandard style rules for =>+ with
+ -- -gnatyt.
Inside_If_Expression : Nat := 0;
-- This is a counter that is set non-zero while scanning out an if
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
- if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
+ if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
-- Handle the following case:
-- after that of Parent_Inst. This relation is established by
-- comparing the Slocs of Parent_Inst freeze node and Inst.
- elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
+ elsif List_Containing (Get_Unit_Instantiation_Node (Par)) =
List_Containing (Inst_Node)
and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
then
end if;
end Get_Instance_Of;
- ------------------------------------
- -- Get_Package_Instantiation_Node --
- ------------------------------------
+ ---------------------------------
+ -- Get_Unit_Instantiation_Node --
+ ---------------------------------
- function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
+ function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is
Decl : Node_Id := Unit_Declaration_Node (A);
Inst : Node_Id;
Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
end if;
- if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
+ if Nkind_In (Original_Node (Decl), N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Instantiation)
+ then
return Original_Node (Decl);
else
return Unit (Parent (Decl));
else
Inst := Next (Decl);
- while not Nkind_In (Inst, N_Package_Instantiation,
- N_Formal_Package_Declaration)
+ while not Nkind_In (Inst, N_Formal_Package_Declaration,
+ N_Function_Instantiation,
+ N_Package_Instantiation,
+ N_Procedure_Instantiation)
loop
Next (Inst);
end loop;
return Inst;
end if;
- end Get_Package_Instantiation_Node;
+ end Get_Unit_Instantiation_Node;
------------------------
-- Has_Been_Exchanged --
-- Parent_Inst. This relation is established by comparing
-- the Slocs of Parent_Inst freeze node and Inst.
- if List_Containing (Get_Package_Instantiation_Node (Par)) =
+ if List_Containing (Get_Unit_Instantiation_Node (Par)) =
List_Containing (N)
and then Sloc (Freeze_Node (Par)) < Sloc (N)
then
-- Load grandparent instance as well
- Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+ Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
if Nkind (Name (Inst_Node)) = N_Expanded_Name then
Inst_Par := Entity (Prefix (Name (Inst_Node)));
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-- Retrieve actual associated with given generic parameter.
-- If A is uninstantiated or not a generic parameter, return A.
- function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
+ function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id;
-- Given the entity of a unit that is an instantiation, retrieve the
-- original instance node. This is used when loading the instantiations
-- of the ancestors of a child generic that is being instantiated.
T := Standard_Integer;
when Aspect_Small =>
- -- Note that the expression can be of any real type (not just
- -- a real universal literal) as long as it is a static constant.
+
+ -- Note that the expression can be of any real type (not just a
+ -- real universal literal) as long as it is a static constant.
T := Any_Real;
if Expander_Active
and then Serious_Errors_Detected = 0
and then Is_Access_Type (R_Type)
- and then Nkind (Expr) /= N_Null
+ and then not Nkind_In (Expr, N_Null, N_Raise_Expression)
and then Is_Interface (Designated_Type (R_Type))
and then Is_Progenitor (Designated_Type (R_Type),
Designated_Type (Etype (Expr)))
Gen_Par :=
Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
- Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
+ Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
if Nkind_In (Inst_Node, N_Package_Instantiation,
N_Formal_Package_Declaration)
Generate_Definition (Obj_Id);
Tasking_Used := True;
- -- A single task declaration is transformed into a pait of an anonymous
+ -- A single task declaration is transformed into a pair of an anonymous
-- task type and an object of that type. Generate:
-- task type Typ is ...;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
-- both the identifier and the parent type of N are not dimensionless,
-- return an error.
+ procedure Analyze_Dimension_Type_Conversion (N : Node_Id);
+ -- Type conversions handle conversions between literals and dimensioned
+ -- types, from dimensioned types to their base type, and between different
+ -- dimensioned systems. Dimensions of the conversion are obtained either
+ -- from those of the expression, or from the target type, and dimensional
+ -- consistency must be checked when converting between values belonging
+ -- to different dimensioned systems.
+
procedure Analyze_Dimension_Unary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
-- Abs operators, propagate the dimensions from the operand to N.
-- dimension" if Description_Needed. if N is dimensionless, return "'[']",
-- or "is dimensionless" if Description_Needed.
+ function Dimension_System_Root (T : Entity_Id) return Entity_Id;
+ -- Given a type that has dimension information, return the type that is the
+ -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
+ -- type, i.e. a standard numeric type, return Empty.
+
procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
-- Issue a warning on the given numeric literal N to indicate that the
-- compiler made the assumption that the literal is not dimensionless
Analyze_Dimension_Subtype_Declaration (N);
when N_Type_Conversion =>
- if In_Instance
- and then Exists (Dimensions_Of (Expression (N)))
- then
- Set_Dimensions (N, Dimensions_Of (Expression (N)));
- else
- Analyze_Dimension_Has_Etype (N);
- end if;
+ Analyze_Dimension_Type_Conversion (N);
when N_Unary_Op =>
Analyze_Dimension_Unary_Op (N);
return Dimensions_Of (Etype (N));
end if;
- -- A type conversion may have been inserted to rewrite other
- -- expressions, e.g. function returns. Dimensions are those of
- -- the target type, unless this is a conversion in an instance,
- -- in which case the proper dimensions are those of the operand,
-
- elsif Nkind (N) = N_Type_Conversion then
- if In_Instance
- and then Is_Generic_Actual_Type (Etype (Expression (N)))
- then
- return Dimensions_Of (Etype (Expression (N)));
-
- elsif In_Instance
- and then Exists (Dimensions_Of (Expression (N)))
- then
- return Dimensions_Of (Expression (N));
-
- else
- return Dimensions_Of (Etype (N));
- end if;
-
-- Otherwise return the default dimensions
else
end if;
end Analyze_Dimension_Subtype_Declaration;
+ ---------------------------------------
+ -- Analyze_Dimension_Type_Conversion --
+ ---------------------------------------
+
+ procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is
+ Expr_Root : constant Entity_Id :=
+ Dimension_System_Root (Etype (Expression (N)));
+ Target_Root : constant Entity_Id :=
+ Dimension_System_Root (Etype (N));
+
+ begin
+ -- If the expression has dimensions and the target type has dimensions,
+ -- the conversion has the dimensions of the expression. Consistency is
+ -- checked below. Converting to a non-dimensioned type such as Float
+ -- ignores the dimensions of the expression.
+
+ if Exists (Dimensions_Of (Expression (N)))
+ and then Present (Target_Root)
+ then
+ Set_Dimensions (N, Dimensions_Of (Expression (N)));
+
+ -- Otherwise the dimensions are those of the target type.
+
+ else
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+
+ -- A conversion between types in different dimension systems (e.g. MKS
+ -- and British units) must respect the dimensions of expression and
+ -- type, It is up to the user to provide proper conversion factors.
+
+ -- Upward conversions to root type of a dimensioned system are legal,
+ -- and correspond to "view conversions", i.e. preserve the dimensions
+ -- of the expression; otherwise conversion must be between types with
+ -- then same dimensions. Conversions to a non-dimensioned type such as
+ -- Float lose the dimensions of the expression.
+
+ if Present (Expr_Root)
+ and then Present (Target_Root)
+ and then Etype (N) /= Target_Root
+ and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N))
+ then
+ Error_Msg_N ("dimensions mismatch in conversion", N);
+ Error_Msg_N
+ ("\expression " & Dimensions_Msg_Of (Expression (N), True), N);
+ Error_Msg_N
+ ("\target type " & Dimensions_Msg_Of (Etype (N), True), N);
+ end if;
+ end Analyze_Dimension_Type_Conversion;
+
--------------------------------
-- Analyze_Dimension_Unary_Op --
--------------------------------
or else Dimensions_Of (T1) = Dimensions_Of (T2);
end Dimensions_Match;
+ ---------------------------
+ -- Dimension_System_Root --
+ ---------------------------
+
+ function Dimension_System_Root (T : Entity_Id) return Entity_Id is
+ Root : Entity_Id;
+
+ begin
+ Root := Base_Type (T);
+
+ if Has_Dimension_System (Root) then
+ return First_Subtype (Root); -- for example Dim_Mks
+
+ else
+ return Empty;
+ end if;
+ end Dimension_System_Root;
+
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------
-- 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.
-- Return True if N is a package instantiation of System.Dim.Integer_IO or
-- of System.Dim.Float_IO.
+ 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 Remove_Dimension_In_Statement (Stmt : Node_Id);
-- Remove the dimensions associated with Stmt
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
procedure Check_Direct_Call is
Typ : Entity_Id := Etype (Control);
-
- function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
- -- Determine whether an entity denotes a user-defined equality
-
- ------------------------------
- -- Is_User_Defined_Equality --
- ------------------------------
-
- function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
- begin
- return
- Ekind (Id) = E_Function
- and then Chars (Id) = Name_Op_Eq
- and then Comes_From_Source (Id)
-
- -- Internally generated equalities have a full type declaration
- -- as their parent.
-
- and then Nkind (Parent (Id)) = N_Function_Specification;
- end Is_User_Defined_Equality;
-
- -- Start of processing for Check_Direct_Call
-
begin
-- Predefined primitives do not receive wrappers since they are built
-- from scratch for the corresponding record of synchronized types.
Next_Elmt (Elmt);
end loop;
- -- For tasks declared in the current unit, trace other calls within
- -- the task procedure bodies, which are available.
+ -- For tasks declared in the current unit, trace other calls within the
+ -- task procedure bodies, which are available.
- In_Task_Activation := True;
+ if not Debug_Flag_Dot_Y then
+ In_Task_Activation := True;
- Elmt := First_Elmt (Intra_Procs);
- while Present (Elmt) loop
- Ent := Node (Elmt);
- Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
- Next_Elmt (Elmt);
- end loop;
+ Elmt := First_Elmt (Intra_Procs);
+ while Present (Elmt) loop
+ Ent := Node (Elmt);
+ Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
+ Next_Elmt (Elmt);
+ end loop;
- In_Task_Activation := False;
+ In_Task_Activation := False;
+ end if;
end Check_Task_Activation;
-------------------------------
-- output a warning.
-- For calls to a subprogram in a with'ed unit or a 'Access or variable
- -- refernece (SPARK mode case), we require that a pragma Elaborate_All
+ -- reference (SPARK mode case), we require that a pragma Elaborate_All
-- or pragma Elaborate be present, or that the referenced unit have a
-- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
-- of these conditions is met, then a warning is generated that a pragma
and then Nkind (Decl) = N_Object_Declaration
then
Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
+
elsif Is_Single_Concurrent_Type_Declaration (Decl) then
- Append_New_Elmt (Anonymous_Object (Defining_Entity (Decl)),
- States_And_Objs);
+ Append_New_Elmt
+ (Anonymous_Object (Defining_Entity (Decl)),
+ States_And_Objs);
end if;
Next (Decl);
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
+ ------------------------------
+ -- Is_User_Defined_Equality --
+ ------------------------------
+
+ function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
+ begin
+ return Ekind (Id) = E_Function
+ and then Chars (Id) = Name_Op_Eq
+ and then Comes_From_Source (Id)
+
+ -- Internally generated equalities have a full type declaration
+ -- as their parent.
+
+ and then Nkind (Parent (Id)) = N_Function_Specification;
+ end Is_User_Defined_Equality;
+
--------------------------------------
-- Is_Validation_Variable_Reference --
--------------------------------------
pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
+ function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
+ -- Determine whether an entity denotes a user-defined equality
+
function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
-- Determine whether N denotes a reference to a variable which captures the
-- value of an object for validation purposes.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
-----------------
-- In check tokens mode (-gnatys), arrow must be surrounded by spaces,
- -- except that within the argument of a Depends macro the required format
- -- is =>+ rather than => +).
+ -- except that within the argument of a Depends or Refined_Depends aspect
+ -- or pragma the required format is "=>+ " rather than "=> +").
procedure Check_Arrow (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
Require_Preceding_Space;
- if not Inside_Depends then
- Require_Following_Space;
-
- -- Special handling for Inside_Depends
+ -- Special handling for Depends and Refined_Depends
- else
+ if Inside_Depends then
if Source (Scan_Ptr) = ' '
and then Source (Scan_Ptr + 1) = '+'
then
then
Require_Following_Space;
end if;
+
+ -- Normal case
+
+ else
+ Require_Following_Space;
end if;
end if;
end Check_Arrow;
-- In check token mode (-gnatyt), unary plus or minus must not be
-- followed by a space.
- -- Annoying exception: if we have the sequence =>+ within a Depends pragma
- -- or aspect, then we insist on a space rather than forbidding it.
+ -- Annoying exception: if we have the sequence =>+ within a Depends or
+ -- Refined_Depends pragma or aspect, then we insist on a space rather
+ -- than forbidding it.
procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
- if not Inside_Depends then
- Check_No_Space_After;
- else
+ if Inside_Depends then
Require_Following_Space;
+ else
+ Check_No_Space_After;
end if;
end if;
end Check_Unary_Plus_Or_Minus;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
procedure Check_Arrow (Inside_Depends : Boolean := False);
-- Called after scanning out an arrow to check spacing. Inside_Depends is
- -- true if the call is from an argument of the Depends pragma (where the
- -- allowed/required format is =>+).
+ -- True if the call is from an argument of the Depends or Refined_Depends
+ -- aspect or pragma (where the allowed/required format is =>+).
procedure Check_Attribute_Name (Reserved : Boolean);
-- The current token is an attribute designator. Check that it
procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False);
-- Called after scanning a unary plus or minus to check spacing. The flag
- -- Inside_Depends is set if we are scanning within a Depends pragma or
- -- Aspect, in which case =>+ requires a following space).
+ -- Inside_Depends is set if we are scanning within a Depends or
+ -- Refined_Depends pragma or Aspect, in which case =>+ requires a
+ -- following space.
procedure Check_Vertical_Bar;
-- Called after scanning a vertical bar to check spacing
projects / platform / upstream / gcc.git / commitdiff