Skip to content

R
riscv-gcc-1
Commit 36504e5f by Arnaud Charlet
Options

[multiple changes] 

2012-04-02  Yannick Moy  <moy@adacore.com>

	* osint.adb, osint.ads (Add_Default_Search_Dirs): Add library
	search dirs in file specified with option -gnateO.

2012-04-02  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor
	reformatting.

2012-04-02  Olivier Hainque  <hainque@adacore.com>

	* g-sse.ads: Add x86-solaris and x86_64-darwin to the set of
	platforms where the use of this spec is supported. Add current
	year to the copyright notice.
	* gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to
	EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support
	it and where they were missing (x86-solaris, x86-freebsd,
	x86_64-freebsd, and x86-darwin).

2012-04-02  Gary Dismukes  <dismukes@adacore.com>

	* bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small
	library, where we no longer suppress the Standard_Library,
	generate an empty body rather than the usual generation of
	assignments to imported globals, since those aren't present in
	the small library.

2012-04-02  Ed Schonberg  <schonberg@adacore.com>

	* sinfo.ads: Minor documentation fix.

2012-04-02  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_res.adb (Resolve_Conditional_Expression): Add local variables
	Else_Typ and Then_Typ. Add missing type conversions to the "then" and
	"else" expressions when their respective types are scalar.

2012-04-02  Vincent Pucci  <pucci@adacore.com>

	* exp_ch9.adb: Reordering of the local subprograms. New Table
	for the lock free implementation that maps each protected
	subprograms with the protected component it references.
	(Allow_Lock_Free_Implementation): New routine. Check if
	the protected body enables the lock free implementation.
	(Build_Lock_Free_Protected_Subprogram_Body): New routine.
	(Build_Lock_Free_Unprotected_Subprogram_Body): New routine.
	(Comp_Of): New routine.
	* Makefile.rtl: Add s-atopri.o
	* debug.adb: New compiler debug flag -gnatd9 for lock free
	implementation.
	* rtsfind.ads: RE_Atomic_Compare_Exchange_8,
	RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32,
	RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8,
	RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8,
	RE_Uint16, RE_Uint32, RE_Uint64 added.
	* s-atropi.ads: New file. Defines atomic primitives used
	by the lock free implementation.

From-SVN: r186076
parent 804670f1
Showing with 1455 additions and 333 deletions
gcc/ada/ChangeLog
2012-04-02 Yannick Moy <moy@adacore.com>
* osint.adb, osint.ads (Add_Default_Search_Dirs): Add library
search dirs in file specified with option -gnateO.
2012-04-02 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor
reformatting.
2012-04-02 Olivier Hainque <hainque@adacore.com>
* g-sse.ads: Add x86-solaris and x86_64-darwin to the set of
platforms where the use of this spec is supported. Add current
year to the copyright notice.
* gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to
EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support
it and where they were missing (x86-solaris, x86-freebsd,
x86_64-freebsd, and x86-darwin).
2012-04-02 Gary Dismukes <dismukes@adacore.com>
* bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small
library, where we no longer suppress the Standard_Library,
generate an empty body rather than the usual generation of
assignments to imported globals, since those aren't present in
the small library.
2012-04-02 Ed Schonberg <schonberg@adacore.com>
* sinfo.ads: Minor documentation fix.
2012-04-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_res.adb (Resolve_Conditional_Expression): Add local variables
Else_Typ and Then_Typ. Add missing type conversions to the "then" and
"else" expressions when their respective types are scalar.
2012-04-02 Vincent Pucci <pucci@adacore.com>
* exp_ch9.adb: Reordering of the local subprograms. New Table
for the lock free implementation that maps each protected
subprograms with the protected component it references.
(Allow_Lock_Free_Implementation): New routine. Check if
the protected body enables the lock free implementation.
(Build_Lock_Free_Protected_Subprogram_Body): New routine.
(Build_Lock_Free_Unprotected_Subprogram_Body): New routine.
(Comp_Of): New routine.
* Makefile.rtl: Add s-atopri.o
* debug.adb: New compiler debug flag -gnatd9 for lock free
implementation.
* rtsfind.ads: RE_Atomic_Compare_Exchange_8,
RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32,
RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8,
RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8,
RE_Uint16, RE_Uint32, RE_Uint64 added.
* s-atropi.ads: New file. Defines atomic primitives used
by the lock free implementation.
2012-04-02 Emmanuel Briot <briot@adacore.com>
* g-expect.adb (Expect_Internal): Fix leak of the input file descriptor.
......
gcc/ada/Makefile.rtl
......@@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \
s-assert$(objext) \
s-atacco$(objext) \
s-atocou$(objext) \
s-atopri$(objext) \
s-auxdec$(objext) \
s-bitops$(objext) \
s-boarop$(objext) \
......
gcc/ada/bindgen.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
......@@ -511,6 +511,14 @@ package body Bindgen is
if CodePeer_Mode then
WBI (" begin");
-- When compiling for the AAMP small library, where the standard library
-- is no longer suppressed, we still want to exclude the setting of the
-- various imported globals, which aren't present for that library.
elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then
WBI (" begin");
WBI (" null;");
-- If the standard library is suppressed, then the only global variables
-- that might be needed (by the Ravenscar profile) are the priority and
-- the processor for the environment task.
......
gcc/ada/debug.adb
......@@ -153,7 +153,7 @@ package body Debug is
-- d6 Default access unconstrained to thin pointers
-- d7 Do not output version & file time stamp in -gnatv or -gnatl mode
-- d8 Force opposite endianness in packed stuff
-- d9
-- d9 Allow lock free implementation
-- Debug flags for binder (GNATBIND)
......@@ -710,6 +710,9 @@ package body Debug is
-- opposite endianness from the actual correct value. Useful in
-- testing out code generation from the packed routines.
-- d9 This allows lock free implementation for protected objects
-- (see Exp_Ch9).
------------------------------------------
-- Documentation for Binder Debug Flags --
------------------------------------------
......
gcc/ada/exp_ch4.adb
......@@ -7832,9 +7832,7 @@ package body Exp_Ch4 is
begin
-- Do validity check if validity checking operands
if Validity_Checks_On
and then Validity_Check_Operands
then
if Validity_Checks_On and then Validity_Check_Operands then
Ensure_Valid (Operand);
end if;
......@@ -7866,7 +7864,7 @@ package body Exp_Ch4 is
-- end if;
-- end loop;
-- Conversely, an existentially quantified expression:
-- Similarly, an existentially quantified expression:
-- for some X in range => Cond
......@@ -7957,7 +7955,6 @@ package body Exp_Ch4 is
Make_Expression_With_Actions (Loc,
Expression => New_Occurrence_Of (Flag, Loc),
Actions => Actions));
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Quantified_Expression;
......
gcc/ada/exp_ch9.adb
......@@ -25,6 +25,7 @@
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
......@@ -60,6 +61,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
......@@ -75,6 +77,34 @@ package body Exp_Ch9 is
Entry_Family_Bound : constant Int := 2**16;
------------------------------
-- Lock Free Data Structure --
------------------------------
-- A data structure used for the Lock Free (LF) implementation of protected
-- objects. Since a protected subprogram can only access a single protected
-- component in the LF implementation, this structure stores each protected
-- subprogram and its accessed protected component when the protected
-- object allows the LF implementation.
type Lock_Free_Sub_Type is record
Sub_Body : Node_Id;
Comp_Id : Entity_Id;
end record;
subtype Subprogram_Id is Nat;
-- The following table used for the Lock Free implementation of protected
-- objects maps Lock_Free_Sub_Type to Subprogram_Id.
package LF_Sub_Table is new Table.Table (
Table_Component_Type => Lock_Free_Sub_Type,
Table_Index_Type => Subprogram_Id,
Table_Low_Bound => 1,
Table_Initial => 5,
Table_Increment => 5,
Table_Name => "LF_Sub_Table");
-----------------------
-- Local Subprograms --
-----------------------
......@@ -109,6 +139,10 @@ package body Exp_Ch9 is
-- Decls is the list of declarations to be enhanced.
-- Ent is the entity for the original entry body.
function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean;
-- Given a protected body N, return True if N permits a lock free
-- implementation.
function Build_Accept_Body (Astat : Node_Id) return Node_Id;
-- Transform accept statement into a block with added exception handler.
-- Used both for simple accept statements and for accept alternatives in
......@@ -144,6 +178,32 @@ package body Exp_Ch9 is
-- of the range of each entry family. A single array with that size is
-- allocated for each concurrent object of the type.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
-- Build subprogram declaration for previous one
function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of a protected
-- subprogram when the protected type denoted by Pid allows the lock free
-- implementation. It only contains a call to the unprotected version of
-- the subprogram body.
function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id;
-- This function is used to construct the lock free version of an
-- unprotected subprogram when the protected type denoted by Pid allows the
-- lock free implementation.
function Build_Parameter_Block
(Loc : Source_Ptr;
Actuals : List_Id;
......@@ -169,49 +229,6 @@ package body Exp_Ch9 is
-- and Decl is the enclosing synchronized type declaration at whose
-- freeze point the generated body is analyzed.
function Build_Renamed_Formal_Declaration
(New_F : Entity_Id;
Formal : Entity_Id;
Comp : Entity_Id;
Renamed_Formal : Node_Id) return Node_Id;
-- Create a renaming declaration for a formal, within a protected entry
-- body or an accept body. The renamed object is a component of the
-- parameter block that is a parameter in the entry call.
-- In Ada 2012, if the formal is an incomplete tagged type, the renaming
-- does not dereference the corresponding component to prevent an illegal
-- use of the incomplete type (AI05-0151).
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Typ : Entity_Id;
N : Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all bodies
-- will be placed. This routine builds the bodies of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new body is analyzed.
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Typ : Entity_Id;
N : in out Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all specs
-- will be placed. This routine builds the specs of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new spec is analyzed.
function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id;
-- Build the function that translates the entry index in the call
-- (which depends on the size of entry families) into an index into the
-- Entry_Bodies_Array, to determine the body and barrier function used
-- in a protected entry call. A pointer to this function appears in every
-- protected object.
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id;
-- Build subprogram declaration for previous one
function Build_Protected_Entry
(N : Node_Id;
Ent : Entity_Id;
......@@ -252,6 +269,19 @@ package body Exp_Ch9 is
-- a cleanup handler that unlocks the object in all cases.
-- (see Exp_Ch7.Expand_Cleanup_Actions).
function Build_Renamed_Formal_Declaration
(New_F : Entity_Id;
Formal : Entity_Id;
Comp : Entity_Id;
Renamed_Formal : Node_Id) return Node_Id;
-- Create a renaming declaration for a formal, within a protected entry
-- body or an accept body. The renamed object is a component of the
-- parameter block that is a parameter in the entry call.
--
-- In Ada 2012, if the formal is an incomplete tagged type, the renaming
-- does not dereference the corresponding component to prevent an illegal
-- use of the incomplete type (AI05-0151).
function Build_Selected_Name
(Prefix : Entity_Id;
Selector : Entity_Id;
......@@ -291,6 +321,26 @@ package body Exp_Ch9 is
-- subprogram that is called from all protected operations on the same
-- object, including the protected version of the same subprogram.
procedure Build_Wrapper_Bodies
(Loc : Source_Ptr;
Typ : Entity_Id;
N : Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all bodies
-- will be placed. This routine builds the bodies of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new body is analyzed.
procedure Build_Wrapper_Specs
(Loc : Source_Ptr;
Typ : Entity_Id;
N : in out Node_Id);
-- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding
-- record of a concurrent type. N is the insertion node where all specs
-- will be placed. This routine builds the specs of the subprograms which
-- serve as an indirection mechanism to overriding primitives of concurrent
-- types, entries and protected procedures. Any new spec is analyzed.
procedure Collect_Entry_Families
(Loc : Source_Ptr;
Cdecls : List_Id;
......@@ -299,6 +349,10 @@ package body Exp_Ch9 is
-- For each entry family in a concurrent type, create an anonymous array
-- type of the right size, and add a component to the corresponding_record.
function Comp_Of (Sub_Body : Node_Id) return Entity_Id;
-- For the lock free implementation, return the protected component entity
-- referenced in Sub_Body using LF_Sub_Table.
function Concurrent_Object
(Spec_Id : Entity_Id;
Conc_Typ : Entity_Id) return Entity_Id;
......@@ -322,6 +376,26 @@ package body Exp_Ch9 is
-- step of the expansion must to be done after private data has been moved
-- to its final resting scope to ensure proper visibility of debug objects.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
-- its actual dispatching object, its actual parameters and the formal
-- parameters of the overridden interface-level version. If the type of
-- the dispatching object is an access type then an explicit dereference
-- is returned in Object.
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object,
-- the entry name, and the entry family index.
function Family_Offset
(Loc : Source_Ptr;
Hi : Node_Id;
......@@ -358,26 +432,6 @@ package body Exp_Ch9 is
-- the scope of Context_Id and Context_Decls is the declarative list of
-- Context.
procedure Extract_Dispatching_Call
(N : Node_Id;
Call_Ent : out Entity_Id;
Object : out Entity_Id;
Actuals : out List_Id;
Formals : out List_Id);
-- Given a dispatching call, extract the entity of the name of the call,
-- its actual dispatching object, its actual parameters and the formal
-- parameters of the overridden interface-level version. If the type of
-- the dispatching object is an access type then an explicit dereference
-- is returned in Object.
procedure Extract_Entry
(N : Node_Id;
Concval : out Node_Id;
Ename : out Node_Id;
Index : out Node_Id);
-- Given an entry call, returns the associated concurrent object,
-- the entry name, and the entry family index.
function Find_Task_Or_Protected_Pragma
(T : Node_Id;
P : Name_Id) return Node_Id;
......@@ -393,6 +447,9 @@ package body Exp_Ch9 is
-- Task_Body_Procedure of Spec_Id. The returned entity denotes formal
-- parameter _E.
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
function Is_Potentially_Large_Family
(Base_Index : Entity_Id;
Conctyp : Entity_Id;
......@@ -762,6 +819,263 @@ package body Exp_Ch9 is
Prepend_To (Decls, Decl);
end Add_Object_Pointer;
------------------------------------
-- Allow_Lock_Free_Implementation --
------------------------------------
-- Here are the restrictions for the Lock Free implementation
-- Implementation Restrictions on protected declaration
-- There must be only protected scalar components (at least one)
-- Component types must support an atomic compare_exchange primitive
-- (size equals to 1, 2, 4 or 8 bytes).
-- No entries
-- Implementation Restrictions on protected operations
-- Cannot refer to non-constant outside of the scope of the protected
-- operation.
-- Can only access a single protected component: all protected
-- component names appearing in a scope (including nested scopes)
-- must statically denote the same protected component.
-- Fundamental Restrictions on protected operations
-- No loop and procedure call statements
-- Any function call and attribute reference must be static
function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is
Decls : constant List_Id := Declarations (N);
Spec : constant Entity_Id := Corresponding_Spec (N);
Pro_Def : constant Node_Id := Protected_Definition (Parent (Spec));
Pri_Decls : constant List_Id := Private_Declarations (Pro_Def);
Vis_Decls : constant List_Id := Visible_Declarations (Pro_Def);
Comp_Id : Entity_Id;
Comp_Size : Int;
Comp_Type : Entity_Id;
No_Component : Boolean := True;
N_Decl : Node_Id;
function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean;
-- Return True if the protected subprogram body Sub_Body doesn't
-- prevent the lock free code expansion, i.e. Sub_Body meets all the
-- restrictions listed below that allow the lock free implementation.
--
-- Can only access a single protected component
--
-- No loop and procedure call statements
-- Any function call and attribute reference must be static
-- Cannot refer to non-constant outside of the scope of the protected
-- subprogram.
----------------------
-- Permit_Lock_Free --
----------------------
function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is
Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body);
Comp_Id : Entity_Id := Empty;
LF_Sub : Lock_Free_Sub_Type;
function Check_Node (N : Node_Id) return Traverse_Result;
-- Check the node N meet the lock free restrictions
function Check_All_Nodes is new Traverse_Func (Check_Node);
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Comp_Decl : Node_Id;
Id : Entity_Id;
begin
case Nkind (N) is
-- Function call or attribute reference case
when N_Function_Call | N_Attribute_Reference =>
-- Any function call and attribute reference must be static
if not Is_Static_Expression (N) then
return Abandon;
end if;
-- Loop and procedure call statement case
when N_Procedure_Call_Statement | N_Loop_Statement =>
-- No loop and procedure call statements
return Abandon;
-- Identifier case
when N_Identifier =>
if Present (Entity (N)) then
Id := Entity (N);
-- Cannot refer to non-constant entities outside of the
-- scope of the protected subprogram.
if Ekind (Id) in Assignable_Kind
and then Sloc (Scope (Id)) > No_Location
and then not Scope_Within_Or_Same (Scope (Id), Sub_Id)
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
return Abandon;
end if;
-- Can only access a single protected component
if Ekind_In (Id, E_Constant, E_Variable)
and then Present (Prival_Link (Id))
then
Comp_Decl := Parent (Prival_Link (Id));
if Nkind (Comp_Decl) = N_Component_Declaration
and then Is_List_Member (Comp_Decl)
and then List_Containing (Comp_Decl) = Pri_Decls
then
-- Check if another protected component has already
-- been accessed by the subprogram body.
if Present (Comp_Id)
and then Comp_Id /= Prival_Link (Id)
then
return Abandon;
elsif not Present (Comp_Id) then
Comp_Id := Prival_Link (Id);
end if;
end if;
end if;
end if;
-- Ok for all other nodes
when others => return OK;
end case;
return OK;
end Check_Node;
-- Start of processing for Permit_Lock_Free
begin
if Check_All_Nodes (Sub_Body) = OK then
-- Fill LF_Sub with Sub_Body and its corresponding protected
-- component entity and then store LF_Sub in the lock free
-- subprogram table LF_Sub_Table.
LF_Sub.Sub_Body := Sub_Body;
LF_Sub.Comp_Id := Comp_Id;
LF_Sub_Table.Append (LF_Sub);
return True;
else
return False;
end if;
end Permit_Lock_Free;
-- Start of processing for Allow_Lock_Free_Implementation
begin
-- Debug switch -gnatd9 enables Lock Free implementation
if not Debug_Flag_9 then
return False;
end if;
-- Look for any entries declared in the visible part of the protected
-- declaration.
N_Decl := First (Vis_Decls);
while Present (N_Decl) loop
if Nkind (N_Decl) = N_Entry_Declaration then
return False;
end if;
N_Decl := Next (N_Decl);
end loop;
-- Look for any entry, plus look for any scalar component declared in
-- the private part of the protected declaration.
N_Decl := First (Pri_Decls);
while Present (N_Decl) loop
-- Check at least one scalar component is declared
if Nkind (N_Decl) = N_Component_Declaration then
if No_Component then
No_Component := False;
end if;
Comp_Id := Defining_Identifier (N_Decl);
Comp_Type := Etype (Comp_Id);
-- Verify the component is a scalar
if not Is_Scalar_Type (Comp_Type) then
return False;
end if;
Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type)));
-- Check the size of the component is 8, 16, 32 or 64 bits
case Comp_Size is
when 8 | 16 | 32 | 64 =>
null;
when others =>
return False;
end case;
-- Check there is no entry declared in the private part.
else
if Nkind (N_Decl) = N_Entry_Declaration then
return False;
end if;
end if;
N_Decl := Next (N_Decl);
end loop;
-- One scalar component must be present
if No_Component then
return False;
end if;
-- Ensure all protected subprograms meet the restrictions that allow the
-- lock free implementation.
N_Decl := First (Decls);
while Present (N_Decl) loop
if Nkind (N_Decl) = N_Subprogram_Body
and then not Permit_Lock_Free (N_Decl)
then
return False;
end if;
Next (N_Decl);
end loop;
return True;
end Allow_Lock_Free_Implementation;
-----------------------
-- Build_Accept_Body --
-----------------------
......@@ -2696,180 +3010,700 @@ package body Exp_Ch9 is
begin
-- Index for current entry body
Index := Index + 1;
Index := Index + 1;
-- Compute total length of entry queues so far
if No (Siz) then
Siz := Expr;
else
Siz :=
Make_Op_Add (Loc,
Left_Opnd => Siz,
Right_Opnd => Expr);
end if;
Cond :=
Make_Op_Le (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uE),
Right_Opnd => Siz);
-- Map entry queue indexes in the range of the current family
-- into the current index, that designates the entry body.
if No (If_St) then
If_St :=
Make_Implicit_If_Statement (Typ,
Condition => Cond,
Then_Statements => Stats,
Elsif_Parts => New_List);
Ret := If_St;
else
Append_To (Elsif_Parts (If_St),
Make_Elsif_Part (Loc,
Condition => Cond,
Then_Statements => Stats));
end if;
end Add_If_Clause;
------------------------------
-- Convert_Discriminant_Ref --
------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
B : Node_Id;
begin
if Is_Entity_Name (Bound)
and then Ekind (Entity (Bound)) = E_Discriminant
then
B :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
Make_Explicit_Dereference (Loc,
Make_Identifier (Loc, Name_uObject))),
Selector_Name => Make_Identifier (Loc, Chars (Bound)));
Set_Etype (B, Etype (Entity (Bound)));
else
B := New_Copy_Tree (Bound);
end if;
return B;
end Convert_Discriminant_Ref;
-- Start of processing for Build_Find_Body_Index
begin
Spec := Build_Find_Body_Index_Spec (Typ);
Ent := First_Entity (Typ);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
Has_F := True;
exit;
end if;
Next_Entity (Ent);
end loop;
if not Has_F then
-- If the protected type has no entry families, there is a one-one
-- correspondence between entry queue and entry body.
Ret :=
Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_uE));
else
-- Suppose entries e1, e2, ... have size l1, l2, ... we generate
-- the following:
-- if E <= l1 then return 1;
-- elsif E <= l1 + l2 then return 2;
-- ...
Index := 0;
Siz := Empty;
Ent := First_Entity (Typ);
Add_Object_Pointer (Loc, Typ, Decls);
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Add_If_Clause (Make_Integer_Literal (Loc, 1));
elsif Ekind (Ent) = E_Entry_Family then
E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
end if;
Next_Entity (Ent);
end loop;
if Index = 1 then
Decls := New_List;
Ret :=
Make_Simple_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1));
elsif Nkind (Ret) = N_If_Statement then
-- Ranges are in increasing order, so last one doesn't need guard
declare
Nod : constant Node_Id := Last (Elsif_Parts (Ret));
begin
Remove (Nod);
Set_Else_Statements (Ret, Then_Statements (Nod));
end;
end if;
end if;
return
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
--------------------------------
-- Build_Find_Body_Index_Spec --
--------------------------------
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Result_Definition => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
-----------------------------------------------
-- Build_Lock_Free_Protected_Subprogram_Body --
-----------------------------------------------
function Build_Lock_Free_Protected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
P_Op_Spec : Node_Id;
Uactuals : List_Id;
Pformal : Node_Id;
Unprot_Call : Node_Id;
R : Node_Id;
Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
Exc_Safe : Boolean;
begin
Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N);
P_Op_Spec :=
Build_Protected_Sub_Specification (N, Pid, Protected_Mode);
-- Build a list of the formal parameters of the protected version of
-- the subprogram to use as the actual parameters of the unprotected
-- version.
Uactuals := New_List;
Pformal := First (Parameter_Specifications (P_Op_Spec));
while Present (Pformal) loop
Append_To (Uactuals,
Make_Identifier (Loc, Chars (Defining_Identifier (Pformal))));
Next (Pformal);
end loop;
-- Make a call to the unprotected version of the subprogram built above
-- for use by the protected version built below.
if Nkind (Op_Spec) = N_Function_Specification then
if Exc_Safe then
R := Make_Temporary (Loc, 'R');
Unprot_Call :=
Make_Object_Declaration (Loc,
Defining_Identifier => R,
Constant_Present => True,
Object_Definition => New_Copy (Result_Definition (N_Op_Spec)),
Expression =>
Make_Function_Call (Loc,
Name => Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
Return_Stmt :=
Make_Simple_Return_Statement (Loc,
Expression => New_Reference_To (R, Loc));
else
Unprot_Call := Make_Simple_Return_Statement (Loc,
Expression => Make_Function_Call (Loc,
Name =>
Make_Identifier (Loc,
Chars => Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals));
end if;
else
Unprot_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))),
Parameter_Associations => Uactuals);
end if;
if Nkind (Op_Spec) = N_Function_Specification
and then Exc_Safe
then
Unprot_Call :=
Make_Block_Statement (Loc,
Declarations => New_List (Unprot_Call),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Return_Stmt)));
end if;
return
Make_Subprogram_Body (Loc,
Declarations => Empty_List,
Specification => P_Op_Spec,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Unprot_Call)));
end Build_Lock_Free_Protected_Subprogram_Body;
-------------------------------------------------
-- Build_Lock_Free_Unprotected_Subprogram_Body --
-------------------------------------------------
function Build_Lock_Free_Unprotected_Subprogram_Body
(N : Node_Id;
Pid : Node_Id) return Node_Id
is
Decls : constant List_Id := Declarations (N);
Is_Procedure : constant Boolean :=
Ekind (Corresponding_Spec (N)) = E_Procedure;
Loc : constant Source_Ptr := Sloc (N);
function Ren_Comp_Id (Decls : List_Id) return Entity_Id;
-- Given the list of delaration Decls, return the renamed entity
-- of the protected component accessed by the subprogram body.
-----------------
-- Ren_Comp_Id --
-----------------
function Ren_Comp_Id (Decls : List_Id) return Entity_Id is
N_Decl : Node_Id;
Pri_Link : Node_Id;
begin
N_Decl := First (Decls);
while Present (N_Decl) loop
-- Look for a renaming declaration
if Nkind (N_Decl) = N_Object_Renaming_Declaration then
Pri_Link := Prival_Link (Defining_Identifier (N_Decl));
-- Compare the renamed entity and the accessed component entity
-- in the LF_Sub_Table.
if Present (Pri_Link) and then Pri_Link = Comp_Of (N) then
return Defining_Identifier (N_Decl);
end if;
end if;
Next (N_Decl);
end loop;
return Empty;
end Ren_Comp_Id;
Obj_Id : constant Entity_Id := Ren_Comp_Id (Decls);
At_Comp_Id : Entity_Id;
At_Load_Id : Entity_Id;
Copy_Id : Entity_Id;
Exit_Stmt : Node_Id;
Label : Node_Id := Empty;
Label_Id : Entity_Id;
New_Body : Node_Id;
New_Decls : List_Id;
New_Stmts : List_Id;
Obj_Typ : Entity_Id;
Old_Id : Entity_Id;
Typ_Size : Int;
Unsigned_Id : Entity_Id;
function Make_If (Stmt : Node_Id) return Node_Id;
-- Given the statement Stmt, return an if statement with Stmt at the end
-- of the list of statements.
procedure Process_Stmts (Stmts : List_Id);
-- Wrap each return and raise statements in Stmts into an if statement
-- generated by Make_If. Replace all references to the protected object
-- Obj by a reference to its copy Obj_Copy.
-------------
-- Make_If --
-------------
function Make_If (Stmt : Node_Id) return Node_Id is
begin
-- Generate (for Typ_Size = 32):
-- if System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- then
-- < Stmt >
-- else
-- goto L0;
-- end if;
-- Check whether a label has already been created
if not Present (Label) then
-- Create a label which will point just after the last
-- statement of the loop statement generated in step 3.
-- Generate:
-- L0 : Label;
Label_Id :=
Make_Identifier (Loc, New_External_Name ('L', 0));
Set_Entity (Label_Id,
Make_Defining_Identifier (Loc, Chars (Label_Id)));
Label := Make_Label (Loc, Label_Id);
Append_To (Decls,
Make_Implicit_Label_Declaration (Loc,
Defining_Identifier => Entity (Label_Id),
Label_Construct => Label));
end if;
return
Make_If_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, Loc)))),
Then_Statements => New_List (
Relocate_Node (Stmt)),
Else_Statements => New_List (
Make_Goto_Statement (Loc,
Name => New_Reference_To (Entity (Label_Id), Loc))));
end Make_If;
-------------------
-- Process_Stmts --
-------------------
procedure Process_Stmts (Stmts : List_Id) is
Stmt : Node_Id;
function Check_Node (N : Node_Id) return Traverse_Result;
-- Recognize a return and raise statement and wrap it into an if
-- statement. Replace all references to the protected object by
-- a reference to its copy. Reset all Analyzed flags in order to
-- reanalyze statments inside the new unprotected subprogram body.
procedure Process_Nodes is
new Traverse_Proc (Check_Node);
----------------
-- Check_Node --
----------------
function Check_Node (N : Node_Id) return Traverse_Result is
begin
-- In case of a procedure, wrap each return and raise statements
-- inside an if statement created by Make_If.
if Is_Procedure
and then Nkind_In (N, N_Simple_Return_Statement,
N_Extended_Return_Statement,
N_Raise_Statement)
and then
(Nkind (N) /= N_Simple_Return_Statement
or else N /= Last (Stmts))
then
Rewrite (N, Make_If (N));
return Skip;
-- Replace all references to the protected object by a reference
-- to the new copy.
elsif Nkind (N) = N_Identifier
and then Present (Entity (N))
and then Entity (N) = Obj_Id
then
Rewrite (N, Make_Identifier (Loc, Chars (Copy_Id)));
return Skip;
end if;
-- We mark the node as unanalyzed in order to reanalyze it inside
-- the unprotected subprogram body.
Set_Analyzed (N, False);
return OK;
end Check_Node;
-- Start of processing for Process_Stmts
begin
-- Process_Nodes for each statement in Stmts
Stmt := First (Stmts);
while Present (Stmt) loop
Process_Nodes (Stmt);
Next (Stmt);
end loop;
end Process_Stmts;
-- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body
begin
New_Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N)));
-- Do the transformation only if the subprogram accesses a protected
-- component.
if not Present (Obj_Id) then
goto Continue;
end if;
Copy_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Obj_Id), Suffix => "_copy"));
Obj_Typ := Etype (Obj_Id);
Typ_Size := UI_To_Int (Esize (Base_Type (Obj_Typ)));
Process_Stmts (New_Stmts);
-- Procedure case
if Is_Procedure then
case Typ_Size is
when 8 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_8);
At_Load_Id := RTE (RE_Atomic_Load_8);
Unsigned_Id := RTE (RE_Uint8);
when 16 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_16);
At_Load_Id := RTE (RE_Atomic_Load_16);
Unsigned_Id := RTE (RE_Uint16);
-- Compute total length of entry queues so far
when 32 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32);
At_Load_Id := RTE (RE_Atomic_Load_32);
Unsigned_Id := RTE (RE_Uint32);
if No (Siz) then
Siz := Expr;
else
Siz :=
Make_Op_Add (Loc,
Left_Opnd => Siz,
Right_Opnd => Expr);
end if;
when 64 =>
At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_64);
At_Load_Id := RTE (RE_Atomic_Load_64);
Unsigned_Id := RTE (RE_Uint64);
when others => null;
end case;
Cond :=
Make_Op_Le (Loc,
Left_Opnd => Make_Identifier (Loc, Name_uE),
Right_Opnd => Siz);
-- Generate (e.g. for Typ_Size = 32):
-- begin
-- loop
-- declare
-- Obj_Old : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
-- begin
-- < New_Stmts >
-- exit when
-- System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
-- end;
-- end loop;
-- end;
-- Step 1: Define a copy and save the old value of the protected
-- object. The copy replaces all the references to the object present
-- in the body of the procedure.
-- Map entry queue indexes in the range of the current family
-- into the current index, that designates the entry body.
-- Generate:
if No (If_St) then
If_St :=
Make_Implicit_If_Statement (Typ,
Condition => Cond,
Then_Statements => Stats,
Elsif_Parts => New_List);
-- Obj_Old : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
-- Obj_Copy : Obj_Typ := Obj_Old;
Ret := If_St;
Old_Id := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Obj_Id), Suffix => "_old"));
else
Append (
Make_Elsif_Part (Loc,
Condition => Cond,
Then_Statements => Stats),
Elsif_Parts (If_St));
end if;
end Add_If_Clause;
New_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Old_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => Unchecked_Convert_To (Obj_Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (At_Load_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address))))),
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Id,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => New_Reference_To (Old_Id, Loc)));
------------------------------
-- Convert_Discriminant_Ref --
------------------------------
-- Step 2: Create an exit statement of the loop statement generated
-- in step 3.
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
B : Node_Id;
-- Generate (for Typ_Size = 32):
begin
if Is_Entity_Name (Bound)
and then Ekind (Entity (Bound)) = E_Discriminant
then
B :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
Make_Explicit_Dereference (Loc,
Make_Identifier (Loc, Name_uObject))),
Selector_Name => Make_Identifier (Loc, Chars (Bound)));
Set_Etype (B, Etype (Entity (Bound)));
-- exit when System.Atomic_Primitives.Atomic_Compare_Exchange_32
-- (Obj'Address,
-- Interfaces.Unsigned_32! (Obj_Old),
-- Interfaces.Unsigned_32! (Obj_Copy));
Exit_Stmt :=
Make_Exit_Statement (Loc,
Condition =>
Make_Function_Call (Loc,
Name => New_Reference_To (At_Comp_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Old_Id, Loc)),
Unchecked_Convert_To (Unsigned_Id,
New_Reference_To (Copy_Id, Loc)))));
-- Check the last statement is a return statement
if Nkind (Last (New_Stmts)) = N_Simple_Return_Statement then
Rewrite (Last (New_Stmts), Exit_Stmt);
else
B := New_Copy_Tree (Bound);
Append_To (New_Stmts, Exit_Stmt);
end if;
return B;
end Convert_Discriminant_Ref;
-- Start of processing for Build_Find_Body_Index
-- Step 3: Create the loop statement which encloses a block
-- declaration that contains all the statements of the original
-- procedure body.
begin
Spec := Build_Find_Body_Index_Spec (Typ);
-- Generate:
Ent := First_Entity (Typ);
while Present (Ent) loop
if Ekind (Ent) = E_Entry_Family then
Has_F := True;
exit;
end if;
-- loop
-- declare
-- < New_Decls >
-- begin
-- < New_Stmts >
-- end;
-- end loop;
Next_Entity (Ent);
end loop;
New_Stmts := New_List (
Make_Loop_Statement (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
Declarations => New_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_Stmts))),
End_Label => Empty));
if not Has_F then
-- Append the label to the statements of the loop when needed
-- If the protected type has no entry families, there is a one-one
-- correspondence between entry queue and entry body.
if Present (Label) then
Append_To (Statements (First (New_Stmts)), Label);
end if;
Ret :=
Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_uE));
-- Function case
else
-- Suppose entries e1, e2, ... have size l1, l2, ... we generate
-- the following:
--
-- if E <= l1 then return 1;
-- elsif E <= l1 + l2 then return 2;
-- ...
Index := 0;
Siz := Empty;
Ent := First_Entity (Typ);
case Typ_Size is
when 8 =>
At_Load_Id := RTE (RE_Atomic_Load_8);
when 16 =>
At_Load_Id := RTE (RE_Atomic_Load_16);
when 32 =>
At_Load_Id := RTE (RE_Atomic_Load_32);
when 64 =>
At_Load_Id := RTE (RE_Atomic_Load_64);
when others => null;
end case;
Add_Object_Pointer (Loc, Typ, Decls);
-- Define a copy of the protected object which replaces all the
-- references to the object present in the body of the function.
while Present (Ent) loop
if Ekind (Ent) = E_Entry then
Add_If_Clause (Make_Integer_Literal (Loc, 1));
-- Generate:
elsif Ekind (Ent) = E_Entry_Family then
E_Typ := Etype (Discrete_Subtype_Definition (Parent (Ent)));
Hi := Convert_Discriminant_Ref (Type_High_Bound (E_Typ));
Lo := Convert_Discriminant_Ref (Type_Low_Bound (E_Typ));
Add_If_Clause (Family_Size (Loc, Hi, Lo, Typ, False));
end if;
-- Obj_Copy : constant Obj_Typ :=
-- Obj_Typ!
-- (System.Atomic_Primitives.Atomic_Load_32
-- (Obj'Address));
Next_Entity (Ent);
end loop;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Copy_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Obj_Typ, Loc),
Expression => Unchecked_Convert_To (Obj_Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (At_Load_Id, Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Obj_Id, Loc),
Attribute_Name => Name_Address))))));
end if;
if Index = 1 then
Decls := New_List;
Ret :=
Make_Simple_Return_Statement (Loc,
Expression => Make_Integer_Literal (Loc, 1));
<< Continue >>
elsif Nkind (Ret) = N_If_Statement then
-- Add renamings for the Protection object, discriminals, privals and
-- the entry index constant for use by debugger.
-- Ranges are in increasing order, so last one doesn't need guard
Debug_Private_Data_Declarations (Decls);
declare
Nod : constant Node_Id := Last (Elsif_Parts (Ret));
begin
Remove (Nod);
Set_Else_Statements (Ret, Then_Statements (Nod));
end;
end if;
end if;
-- Make an unprotected version of the subprogram for use within the same
-- object, with new name and extra parameter representing the object.
return
New_Body :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Specification =>
Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
end Build_Find_Body_Index;
--------------------------------
-- Build_Find_Body_Index_Spec --
--------------------------------
function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Typ);
Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'F'));
Parm1 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uO);
Parm2 : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uE);
begin
return
Make_Function_Specification (Loc,
Defining_Unit_Name => Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm1,
Parameter_Type =>
New_Reference_To (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Parm2,
Parameter_Type =>
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Result_Definition => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
end Build_Find_Body_Index_Spec;
Statements => New_Stmts));
return New_Body;
end Build_Lock_Free_Unprotected_Subprogram_Body;
-------------------------
-- Build_Master_Entity --
......@@ -3442,102 +4276,6 @@ package body Exp_Ch9 is
Exc_Safe : Boolean;
Lock_Kind : RE_Id;
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean;
-- Tell whether a given subprogram cannot raise an exception
-----------------------
-- Is_Exception_Safe --
-----------------------
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
function Has_Side_Effect (N : Node_Id) return Boolean;
-- Return True whenever encountering a subprogram call or raise
-- statement of any kind in the sequence of statements
---------------------
-- Has_Side_Effect --
---------------------
-- What is this doing buried two levels down in exp_ch9. It seems
-- like a generally useful function, and indeed there may be code
-- duplication going on here ???
function Has_Side_Effect (N : Node_Id) return Boolean is
Stmt : Node_Id;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
-- Indicate whether N is a subprogram call or a raise statement
----------------------
-- Is_Call_Or_Raise --
----------------------
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Procedure_Call_Statement,
N_Function_Call,
N_Raise_Statement,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error);
end Is_Call_Or_Raise;
-- Start of processing for Has_Side_Effect
begin
Stmt := N;
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
end if;
-- An object declaration can also contain a function call
-- or a raise statement
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr) and then Is_Call_Or_Raise (Expr) then
return True;
end if;
end if;
Next (Stmt);
end loop;
return False;
end Has_Side_Effect;
-- Start of processing for Is_Exception_Safe
begin
-- If the checks handled by the back end are not disabled, we cannot
-- ensure that no exception will be raised.
if not Access_Checks_Suppressed (Empty)
or else not Discriminant_Checks_Suppressed (Empty)
or else not Range_Checks_Suppressed (Empty)
or else not Index_Checks_Suppressed (Empty)
or else Opt.Stack_Checking_Enabled
then
return False;
end if;
if Has_Side_Effect (First (Declarations (Subprogram)))
or else
Has_Side_Effect (
First (Statements (Handled_Statement_Sequence (Subprogram))))
then
return False;
else
return True;
end if;
end Is_Exception_Safe;
-- Start of processing for Build_Protected_Subprogram_Body
begin
Op_Spec := Specification (N);
Exc_Safe := Is_Exception_Safe (N);
......@@ -4698,6 +5436,21 @@ package body Exp_Ch9 is
end loop;
end Collect_Entry_Families;
-------------
-- Comp_Of --
-------------
function Comp_Of (Sub_Body : Node_Id) return Entity_Id is
begin
for Sub_Id in 1 .. LF_Sub_Table.Last loop
if Sub_Body = LF_Sub_Table.Table (Sub_Id).Sub_Body then
return LF_Sub_Table.Table (Sub_Id).Comp_Id;
end if;
end loop;
return Empty;
end Comp_Of;
-----------------------
-- Concurrent_Object --
-----------------------
......@@ -7715,6 +8468,9 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N);
Pid : constant Entity_Id := Corresponding_Spec (N);
Lock_Free_On : constant Boolean := Allow_Lock_Free_Implementation (N);
-- This flag indicates whether the lock free implementation is active
Current_Node : Node_Id;
Disp_Op_Body : Node_Id;
New_Op_Body : Node_Id;
......@@ -7843,8 +8599,14 @@ package body Exp_Ch9 is
if not Is_Eliminated (Defining_Entity (Op_Body))
and then not Is_Eliminated (Corresponding_Spec (Op_Body))
then
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
if Lock_Free_On then
New_Op_Body :=
Build_Lock_Free_Unprotected_Subprogram_Body
(Op_Body, Pid);
else
New_Op_Body :=
Build_Unprotected_Subprogram_Body (Op_Body, Pid);
end if;
Insert_After (Current_Node, New_Op_Body);
Current_Node := New_Op_Body;
......@@ -7854,6 +8616,7 @@ package body Exp_Ch9 is
-- appear that this is needed only if this is a visible
-- operation of the type, or if it is an interrupt handler,
-- and this was the strategy used previously in GNAT.
-- However, the operation may be exported through a 'Access
-- to an external caller. This is the common idiom in code
-- that uses the Ada 2005 Timing_Events package. As a result
......@@ -7863,9 +8626,15 @@ package body Exp_Ch9 is
-- declaration in the protected body itself.
if Present (Corresponding_Spec (Op_Body)) then
New_Op_Body :=
Build_Protected_Subprogram_Body (
Op_Body, Pid, Specification (New_Op_Body));
if Lock_Free_On then
New_Op_Body :=
Build_Lock_Free_Protected_Subprogram_Body
(Op_Body, Pid, Specification (New_Op_Body));
else
New_Op_Body :=
Build_Protected_Subprogram_Body
(Op_Body, Pid, Specification (New_Op_Body));
end if;
Insert_After (Current_Node, New_Op_Body);
Analyze (New_Op_Body);
......@@ -12688,6 +13457,97 @@ package body Exp_Ch9 is
end if;
end Install_Private_Data_Declarations;
-----------------------
-- Is_Exception_Safe --
-----------------------
function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is
function Has_Side_Effect (N : Node_Id) return Boolean;
-- Return True whenever encountering a subprogram call or raise
-- statement of any kind in the sequence of statements
---------------------
-- Has_Side_Effect --
---------------------
-- What is this doing buried two levels down in exp_ch9. It seems like a
-- generally useful function, and indeed there may be code duplication
-- going on here ???
function Has_Side_Effect (N : Node_Id) return Boolean is
Stmt : Node_Id;
Expr : Node_Id;
function Is_Call_Or_Raise (N : Node_Id) return Boolean;
-- Indicate whether N is a subprogram call or a raise statement
----------------------
-- Is_Call_Or_Raise --
----------------------
function Is_Call_Or_Raise (N : Node_Id) return Boolean is
begin
return Nkind_In (N, N_Procedure_Call_Statement,
N_Function_Call,
N_Raise_Statement,
N_Raise_Constraint_Error,
N_Raise_Program_Error,
N_Raise_Storage_Error);
end Is_Call_Or_Raise;
-- Start of processing for Has_Side_Effect
begin
Stmt := N;
while Present (Stmt) loop
if Is_Call_Or_Raise (Stmt) then
return True;
end if;
-- An object declaration can also contain a function call or a
-- raise statement.
if Nkind (Stmt) = N_Object_Declaration then
Expr := Expression (Stmt);
if Present (Expr) and then Is_Call_Or_Raise (Expr) then
return True;
end if;
end if;
Next (Stmt);
end loop;
return False;
end Has_Side_Effect;
-- Start of processing for Is_Exception_Safe
begin
-- If the checks handled by the back end are not disabled, we cannot
-- ensure that no exception will be raised.
if not Access_Checks_Suppressed (Empty)
or else not Discriminant_Checks_Suppressed (Empty)
or else not Range_Checks_Suppressed (Empty)
or else not Index_Checks_Suppressed (Empty)
or else Opt.Stack_Checking_Enabled
then
return False;
end if;
if Has_Side_Effect (First (Declarations (Subprogram)))
or else
Has_Side_Effect
(First (Statements (Handled_Statement_Sequence (Subprogram))))
then
return False;
else
return True;
end if;
end Is_Exception_Safe;
---------------------------------
-- Is_Potentially_Large_Family --
---------------------------------
......@@ -12702,11 +13562,12 @@ package body Exp_Ch9 is
return Scope (Base_Index) = Standard_Standard
and then Base_Index = Base_Type (Standard_Integer)
and then Has_Discriminants (Conctyp)
and then Present
(Discriminant_Default_Value (First_Discriminant (Conctyp)))
and then
Present (Discriminant_Default_Value (First_Discriminant (Conctyp)))
and then
(Denotes_Discriminant (Lo, True)
or else Denotes_Discriminant (Hi, True));
or else
Denotes_Discriminant (Hi, True));
end Is_Potentially_Large_Family;
-------------------------------------
......
gcc/ada/exp_util.adb
......@@ -3948,8 +3948,7 @@ package body Exp_Util is
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a controlled function
-- call.
-- Determine if particular node denotes a controlled function call
function Is_Displace_Call (N : Node_Id) return Boolean;
-- Determine whether a particular node is a call to Ada.Tags.Displace.
......@@ -4065,7 +4064,7 @@ package body Exp_Util is
and then Is_Displace_Call (Renamed_Object (Obj_Id))
and then
(Is_Controlled_Function_Call (Expression (Orig_Decl))
or else Is_Source_Object (Expression (Orig_Decl)));
or else Is_Source_Object (Expression (Orig_Decl)));
end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
......
gcc/ada/g-sse.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2012, 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- --
......@@ -40,6 +40,8 @@
-- GNU/Linux x86 and x86_64
-- Windows XP/Vista x86 and x86_64
-- Solaris x86
-- Darwin x86_64
-- This unit exposes vector _component_ types together with general comments
-- on the binding contents.
......
gcc/ada/gcc-interface/Makefile.in
......@@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),)
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
......@@ -1175,6 +1177,8 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
......@@ -1231,6 +1235,8 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB= -lpthread
GMEM_LIB = gmemlib
......@@ -1259,6 +1265,8 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB= -lpthread
GMEM_LIB = gmemlib
......@@ -2160,6 +2168,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
$(X86_TARGET_PAIRS) \
system.ads<system-darwin-x86.ads
endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
endif
ifeq ($(strip $(filter-out %x86_64,$(arch))),)
......@@ -2178,6 +2188,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
$(X86_64_TARGET_PAIRS) \
system.ads<system-darwin-x86_64.ads
endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
endif
ifeq ($(strip $(filter-out powerpc%,$(arch))),)
......
gcc/ada/osint.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
......@@ -444,6 +444,15 @@ package body Osint is
-- Start of processing for Add_Default_Search_Dirs
begin
-- If there was a -gnateO switch, add all object directories from the
-- file given in argument to the library search list.
if Object_Path_File_Name /= null then
Path_File_Name := String_Access (Object_Path_File_Name);
pragma Assert (Path_File_Name'Length > 0);
Get_Dirs_From_File (Additional_Source_Dir => False);
end if;
-- After the locations specified on the command line, the next places
-- to look for files are the directories specified by the appropriate
-- environment variable. Get this value, extract the directory names
......
gcc/ada/osint.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
......@@ -324,7 +324,8 @@ package Osint is
procedure Add_Default_Search_Dirs;
-- This routine adds the default search dirs indicated by the environment
-- variables and sdefault package.
-- variables and sdefault package, as well as the library search dirs set
-- by option -gnateO for GNAT2WHY.
procedure Add_Lib_Search_Dir (Dir : String);
-- Add Dir at the end of the library file search path
......
gcc/ada/rtsfind.ads
......@@ -211,6 +211,7 @@ package Rtsfind is
System_Arith_64,
System_AST_Handling,
System_Assertions,
System_Atomic_Primitives,
System_Aux_DEC,
System_Bit_Ops,
System_Boolean_Array_Operations,
......@@ -730,6 +731,19 @@ package Rtsfind is
RE_Assert_Failure, -- System.Assertions
RE_Raise_Assert_Failure, -- System.Assertions
RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives
RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives
RE_Atomic_Load_8, -- System.Atomic_Primitives
RE_Atomic_Load_16, -- System.Atomic_Primitives
RE_Atomic_Load_32, -- System.Atomic_Primitives
RE_Atomic_Load_64, -- System.Atomic_Primitives
RE_Uint8, -- System.Atomic_Primitives
RE_Uint16, -- System.Atomic_Primitives
RE_Uint32, -- System.Atomic_Primitives
RE_Uint64, -- System.Atomic_Primitives
RE_AST_Handler, -- System.Aux_DEC
RE_Import_Value, -- System.Aux_DEC
RE_No_AST_Handler, -- System.Aux_DEC
......@@ -1938,6 +1952,19 @@ package Rtsfind is
RE_Assert_Failure => System_Assertions,
RE_Raise_Assert_Failure => System_Assertions,
RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives,
RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives,
RE_Atomic_Load_8 => System_Atomic_Primitives,
RE_Atomic_Load_16 => System_Atomic_Primitives,
RE_Atomic_Load_32 => System_Atomic_Primitives,
RE_Atomic_Load_64 => System_Atomic_Primitives,
RE_Uint8 => System_Atomic_Primitives,
RE_Uint16 => System_Atomic_Primitives,
RE_Uint32 => System_Atomic_Primitives,
RE_Uint64 => System_Atomic_Primitives,
RE_AST_Handler => System_Aux_DEC,
RE_Import_Value => System_Aux_DEC,
RE_No_AST_Handler => System_Aux_DEC,
......
gcc/ada/s-atopri.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A T O M I C _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2012, 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- --
-- 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. --
-- --
------------------------------------------------------------------------------
package System.Atomic_Primitives is
pragma Preelaborate;
type uint8 is mod 2**8
with Size => 8;
type uint16 is mod 2**16
with Size => 16;
type uint32 is mod 2**32
with Size => 32;
type uint64 is mod 2**64
with Size => 64;
Relaxed : constant := 0;
Consume : constant := 1;
Acquire : constant := 2;
Release : constant := 3;
Acq_Rel : constant := 4;
Seq_Cst : constant := 5;
Last : constant := 6;
subtype Mem_Model is Integer range Relaxed .. Last;
function Atomic_Compare_Exchange_8
(X : Address;
X_Old : uint8;
X_Copy : uint8) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_8,
"__sync_bool_compare_and_swap_1");
-- ??? Should use __atomic_compare_exchange_1 (doesn't work yet):
-- function Atomic_Compare_Exchange_8
-- (X : Address;
-- X_Old : Address;
-- X_Copy : uint8;
-- Success_Model : Mem_Model := Seq_Cst;
-- Failure_Model : Mem_Model := Seq_Cst) return Boolean;
-- pragma Import (Intrinsic,
-- Atomic_Compare_Exchange_8,
-- "__atomic_compare_exchange_1");
function Atomic_Compare_Exchange_16
(X : Address;
X_Old : uint16;
X_Copy : uint16) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_16,
"__sync_bool_compare_and_swap_2");
function Atomic_Compare_Exchange_32
(X : Address;
X_Old : uint32;
X_Copy : uint32) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_32,
"__sync_bool_compare_and_swap_4");
function Atomic_Compare_Exchange_64
(X : Address;
X_Old : uint64;
X_Copy : uint64) return Boolean;
pragma Import (Intrinsic,
Atomic_Compare_Exchange_64,
"__sync_bool_compare_and_swap_8");
function Atomic_Load_8
(X : Address;
Model : Mem_Model := Seq_Cst) return uint8;
pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1");
function Atomic_Load_16
(X : Address;
Model : Mem_Model := Seq_Cst) return uint16;
pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2");
function Atomic_Load_32
(X : Address;
Model : Mem_Model := Seq_Cst) return uint32;
pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4");
function Atomic_Load_64
(X : Address;
Model : Mem_Model := Seq_Cst) return uint64;
pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8");
end System.Atomic_Primitives;
gcc/ada/sem_ch5.adb
......@@ -1666,6 +1666,9 @@ package body Sem_Ch5 is
if not Is_Entity_Name (Iter_Name)
and then (Nkind (Parent (N)) /= N_Quantified_Expression
-- The following two tests need comments ???
or else Operating_Mode = Check_Semantics
or else Alfa_Mode)
then
......
gcc/ada/sem_res.adb
......@@ -2624,10 +2624,10 @@ package body Sem_Res is
-- an error. We can't do this earlier, because it would cause legal
-- cases to get errors (when some other type has an abstract "+").
if Ada_Version >= Ada_2005 and then
Nkind (N) in N_Op and then
Is_Overloaded (N) and then
Is_Universal_Numeric_Type (Etype (Entity (N)))
if Ada_Version >= Ada_2005
and then Nkind (N) in N_Op
and then Is_Overloaded (N)
and then Is_Universal_Numeric_Type (Etype (Entity (N)))
then
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
......@@ -6118,15 +6118,36 @@ package body Sem_Res is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : Node_Id := Next (Then_Expr);
Else_Typ : Entity_Id;
Then_Typ : Entity_Id;
begin
Resolve (Condition, Any_Boolean);
Resolve (Then_Expr, Typ);
Then_Typ := Etype (Then_Expr);
-- When the "then" and "else" expressions are of a scalar type, insert
-- a conversion to ensure the generation of a constraint check.
if Is_Scalar_Type (Then_Typ)
and then Then_Typ /= Typ
then
Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
Analyze_And_Resolve (Then_Expr, Typ);
end if;
-- If ELSE expression present, just resolve using the determined type
if Present (Else_Expr) then
Resolve (Else_Expr, Typ);
Else_Typ := Etype (Else_Expr);
if Is_Scalar_Type (Else_Typ)
and then Else_Typ /= Typ
then
Rewrite (Else_Expr, Convert_To (Typ, Else_Expr));
Analyze_And_Resolve (Else_Expr, Typ);
end if;
-- If no ELSE expression is present, root type must be Standard.Boolean
-- and we provide a Standard.True result converted to the appropriate
......
gcc/ada/sem_util.adb
......@@ -740,15 +740,16 @@ package body Sem_Util is
N : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (N);
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults.
Disc : Entity_Id;
Bas : Entity_Id;
-- The base type that is to be constrained by the defaults
begin
if not Has_Discriminants (T) or else Is_Constrained (T) then
return T;
end if;
Bas := Base_Type (T);
-- If T is non-private but its base type is private, this is
......@@ -757,9 +758,7 @@ package body Sem_Util is
-- proper discriminants are to be found in the full view of
-- the base.
if Is_Private_Type (Bas)
and then Present (Full_View (Bas))
then
if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then
Bas := Full_View (Bas);
end if;
......
gcc/ada/sinfo.ads
......@@ -1252,7 +1252,7 @@ package Sinfo is
-- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12.
-- Is_Accessibility_Actual (Flag12-Sem)
-- Is_Accessibility_Actual (Flag13-Sem)
-- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual
-- for an access parameter, in a function that dispatches on result and
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment