Commit b7d5e87b by Arnaud Charlet

[multiple changes]

2009-12-01  Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads: Clarify use of Is_Private_Primitive.
	* sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a
	private primitive operation only if it is declared in the scope of the
	private controlling type.
	* exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private
	protected operations as well.

2009-12-01  Arnaud Charlet  <charlet@adacore.com>

	* gnat1drv.adb (Adjust_Global_Switches): Disable front-end
	optimizations in CodePeer mode, to keep the tree as close to the source
	code as possible, and also to avoid inconsistencies between trees when
	using different optimization switches.

2009-12-01  Thomas Quinot  <quinot@adacore.com>

	* scos.ads: Updated specification of source coverage obligation
	information.

2009-12-01  Thomas Quinot  <quinot@adacore.com>

	* g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb,
	a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb,
	g-socket.ads (System.Communications.Last_Index): For the case where no
	element has been transferred and Item'First =
	Stream_Element_Offset'First, raise CONSTRAINT_ERROR.

2009-12-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Install_Siblings): A private with_clause on some child
	unit U in an ancestor of the current unit must be ignored if the
	current unit has a regular with_clause on U.

From-SVN: r154868
parent acb85bea
2009-12-01 Ed Schonberg <schonberg@adacore.com>
* einfo.ads: Clarify use of Is_Private_Primitive.
* sem_ch6.adb (Analyze_Subprogram_Declaration): An operation is a
private primitive operation only if it is declared in the scope of the
private controlling type.
* exp_ch9.adb (Build_Wrapper_Spec): Build wrappers for private
protected operations as well.
2009-12-01 Arnaud Charlet <charlet@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Disable front-end
optimizations in CodePeer mode, to keep the tree as close to the source
code as possible, and also to avoid inconsistencies between trees when
using different optimization switches.
2009-12-01 Thomas Quinot <quinot@adacore.com>
* scos.ads: Updated specification of source coverage obligation
information.
2009-12-01 Thomas Quinot <quinot@adacore.com>
* g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb,
a-ststio.adb, s-commun.adb, s-commun.ads, g-socket.adb,
g-socket.ads (System.Communications.Last_Index): For the case where no
element has been transferred and Item'First =
Stream_Element_Offset'First, raise CONSTRAINT_ERROR.
2009-12-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Install_Siblings): A private with_clause on some child
unit U in an ancestor of the current unit must be ignored if the
current unit has a regular with_clause on U.
2009-11-30 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> 2009-11-30 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX * s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX
......
...@@ -29,9 +29,10 @@ ...@@ -29,9 +29,10 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Interfaces.C_Streams; use Interfaces.C_Streams; with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System; with System; use System;
with System.Communication; use System.Communication;
with System.File_IO; with System.File_IO;
with System.Soft_Links; with System.Soft_Links;
with System.CRTL; with System.CRTL;
...@@ -293,8 +294,8 @@ package body Ada.Streams.Stream_IO is ...@@ -293,8 +294,8 @@ package body Ada.Streams.Stream_IO is
end if; end if;
File.Index := File.Index + Count (Nread); File.Index := File.Index + Count (Nread);
Last := Item'First + Stream_Element_Offset (Nread) - 1;
File.Last_Op := Op_Read; File.Last_Op := Op_Read;
Last := Last_Index (Item'First, Nread);
end Read; end Read;
-- This version of Read is the primitive operation on the underlying -- This version of Read is the primitive operation on the underlying
......
...@@ -2098,7 +2098,11 @@ package Einfo is ...@@ -2098,7 +2098,11 @@ package Einfo is
-- Present in all entities. Set true for all entities declared in the -- Present in all entities. Set true for all entities declared in the
-- private part or body of a package. Also marks generic formals of a -- private part or body of a package. Also marks generic formals of a
-- formal package declared without a box. For library level entities, -- formal package declared without a box. For library level entities,
-- this flag is set if the entity is not publicly visible. -- this flag is set if the entity is not publicly visible. This flag
-- is reset when compiling the body of the package where the entity
-- is declared, when compiling the private part or body of a public
-- child unit, and when compiling a private child unit (see Install_
-- Private_Declaration in sem_ch7).
-- Is_Hidden_Open_Scope (Flag171) -- Is_Hidden_Open_Scope (Flag171)
-- Present in all entities. Set true for a scope that contains the -- Present in all entities. Set true for a scope that contains the
...@@ -2451,8 +2455,12 @@ package Einfo is ...@@ -2451,8 +2455,12 @@ package Einfo is
-- child unit, or if it is the descendent of a private child unit. -- child unit, or if it is the descendent of a private child unit.
-- Is_Private_Primitive (Flag245) -- Is_Private_Primitive (Flag245)
-- Present in subprograms. Set if the first parameter of the subprogram -- Present in subprograms. Set if the operation is a primitive of a
-- is of concurrent tagged type with a private view. -- tagged type (procedure or function dispatching on result) whose
-- full view has not been seen. Used in particular for primitive
-- subprograms of a synchronized type declared between the two views
-- of the type, so that the wrapper built for such a subprogram can
-- be given the proper signature.
-- Is_Private_Type (synthesized) -- Is_Private_Type (synthesized)
-- Applies to all entities, true for private types and subtypes, -- Applies to all entities, true for private types and subtypes,
......
...@@ -2180,6 +2180,58 @@ package body Exp_Ch9 is ...@@ -2180,6 +2180,58 @@ package body Exp_Ch9 is
is is
Def : Node_Id; Def : Node_Id;
Rec_Typ : Entity_Id; Rec_Typ : Entity_Id;
procedure Scan_Declarations (L : List_Id);
-- Common processing for visible and private declarations
-- of a protected type.
procedure Scan_Declarations (L : List_Id) is
Decl : Node_Id;
Wrap_Decl : Node_Id;
Wrap_Spec : Node_Id;
begin
if No (L) then
return;
end if;
Decl := First (L);
while Present (Decl) loop
Wrap_Spec := Empty;
if Nkind (Decl) = N_Entry_Declaration
and then Ekind (Defining_Identifier (Decl)) = E_Entry
then
Wrap_Spec :=
Build_Wrapper_Spec
(Subp_Id => Defining_Identifier (Decl),
Obj_Typ => Rec_Typ,
Formals => Parameter_Specifications (Decl));
elsif Nkind (Decl) = N_Subprogram_Declaration then
Wrap_Spec :=
Build_Wrapper_Spec
(Subp_Id => Defining_Unit_Name (Specification (Decl)),
Obj_Typ => Rec_Typ,
Formals =>
Parameter_Specifications (Specification (Decl)));
end if;
if Present (Wrap_Spec) then
Wrap_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Wrap_Spec);
Insert_After (N, Wrap_Decl);
N := Wrap_Decl;
Analyze (Wrap_Decl);
end if;
Next (Decl);
end loop;
end Scan_Declarations;
-- start of processing for Build_Wrapper_Specs
begin begin
if Is_Protected_Type (Typ) then if Is_Protected_Type (Typ) then
...@@ -2191,54 +2243,14 @@ package body Exp_Ch9 is ...@@ -2191,54 +2243,14 @@ package body Exp_Ch9 is
Rec_Typ := Corresponding_Record_Type (Typ); Rec_Typ := Corresponding_Record_Type (Typ);
-- Generate wrapper specs for a concurrent type which implements an -- Generate wrapper specs for a concurrent type which implements an
-- interface and has visible entries and/or protected procedures. -- interface. Operations in both the visible and private parts may
-- implement progenitor operations.
if Present (Interfaces (Rec_Typ)) if Present (Interfaces (Rec_Typ))
and then Present (Def) and then Present (Def)
and then Present (Visible_Declarations (Def))
then then
declare Scan_Declarations (Visible_Declarations (Def));
Decl : Node_Id; Scan_Declarations (Private_Declarations (Def));
Wrap_Decl : Node_Id;
Wrap_Spec : Node_Id;
begin
Decl := First (Visible_Declarations (Def));
while Present (Decl) loop
Wrap_Spec := Empty;
if Nkind (Decl) = N_Entry_Declaration
and then Ekind (Defining_Identifier (Decl)) = E_Entry
then
Wrap_Spec :=
Build_Wrapper_Spec
(Subp_Id => Defining_Identifier (Decl),
Obj_Typ => Rec_Typ,
Formals => Parameter_Specifications (Decl));
elsif Nkind (Decl) = N_Subprogram_Declaration then
Wrap_Spec :=
Build_Wrapper_Spec
(Subp_Id => Defining_Unit_Name (Specification (Decl)),
Obj_Typ => Rec_Typ,
Formals =>
Parameter_Specifications (Specification (Decl)));
end if;
if Present (Wrap_Spec) then
Wrap_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Wrap_Spec);
Insert_After (N, Wrap_Decl);
N := Wrap_Decl;
Analyze (Wrap_Decl);
end if;
Next (Decl);
end loop;
end;
end if; end if;
end Build_Wrapper_Specs; end Build_Wrapper_Specs;
......
...@@ -172,7 +172,7 @@ package body GNAT.Serial_Communications is ...@@ -172,7 +172,7 @@ package body GNAT.Serial_Communications is
Raise_Error ("read failed"); Raise_Error ("read failed");
end if; end if;
Last := Last_Index (Buffer'First, C.int (Res)); Last := Last_Index (Buffer'First, size_t (Res));
end Read; end Read;
--------- ---------
......
...@@ -38,6 +38,7 @@ with Ada.Streams; use Ada.Streams; ...@@ -38,6 +38,7 @@ with Ada.Streams; use Ada.Streams;
with System; use System; with System; use System;
with System.Communication; use System.Communication; with System.Communication; use System.Communication;
with System.CRTL; use System.CRTL;
with System.Win32; use System.Win32; with System.Win32; use System.Win32;
with System.Win32.Ext; use System.Win32.Ext; with System.Win32.Ext; use System.Win32.Ext;
...@@ -162,7 +163,7 @@ package body GNAT.Serial_Communications is ...@@ -162,7 +163,7 @@ package body GNAT.Serial_Communications is
Raise_Error ("read error"); Raise_Error ("read error");
end if; end if;
Last := Last_Index (Buffer'First, C.int (Read_Last)); Last := Last_Index (Buffer'First, size_t (Read_Last));
end Read; end Read;
--------- ---------
......
...@@ -92,8 +92,8 @@ package GNAT.Serial_Communications is ...@@ -92,8 +92,8 @@ package GNAT.Serial_Communications is
Last : out Ada.Streams.Stream_Element_Offset); Last : out Ada.Streams.Stream_Element_Offset);
-- Read a set of bytes, put result into Buffer and set Last accordingly. -- Read a set of bytes, put result into Buffer and set Last accordingly.
-- Last is set to Buffer'First - 1 if no byte has been read, unless -- Last is set to Buffer'First - 1 if no byte has been read, unless
-- Buffer'First = Stream_Element_Offset'First, in which case Last is -- Buffer'First = Stream_Element_Offset'First, in which case
-- set to Stream_Element_Offset'Last instead. -- Constraint_Error raised instead.
overriding procedure Write overriding procedure Write
(Port : in out Serial_Port; (Port : in out Serial_Port;
......
...@@ -48,6 +48,7 @@ pragma Warnings (Off, GNAT.Sockets.Linker_Options); ...@@ -48,6 +48,7 @@ pragma Warnings (Off, GNAT.Sockets.Linker_Options);
with System; use System; with System; use System;
with System.Communication; use System.Communication; with System.Communication; use System.Communication;
with System.CRTL; use System.CRTL;
package body GNAT.Sockets is package body GNAT.Sockets is
...@@ -1636,7 +1637,7 @@ package body GNAT.Sockets is ...@@ -1636,7 +1637,7 @@ package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
Last := Last_Index (First => Item'First, Count => Res); Last := Last_Index (First => Item'First, Count => size_t (Res));
end Receive_Socket; end Receive_Socket;
-------------------- --------------------
...@@ -1668,7 +1669,7 @@ package body GNAT.Sockets is ...@@ -1668,7 +1669,7 @@ package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
Last := Last_Index (First => Item'First, Count => Res); Last := Last_Index (First => Item'First, Count => size_t (Res));
To_Inet_Addr (Sin.Sin_Addr, From.Addr); To_Inet_Addr (Sin.Sin_Addr, From.Addr);
From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
...@@ -1917,7 +1918,7 @@ package body GNAT.Sockets is ...@@ -1917,7 +1918,7 @@ package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
Last := Last_Index (First => Item'First, Count => Res); Last := Last_Index (First => Item'First, Count => size_t (Res));
end Send_Socket; end Send_Socket;
----------------- -----------------
......
...@@ -895,10 +895,11 @@ package GNAT.Sockets is ...@@ -895,10 +895,11 @@ package GNAT.Sockets is
Flags : Request_Flag_Type := No_Request_Flag); Flags : Request_Flag_Type := No_Request_Flag);
-- Receive message from Socket. Last is the index value such that Item -- Receive message from Socket. Last is the index value such that Item
-- (Last) is the last character assigned. Note that Last is set to -- (Last) is the last character assigned. Note that Last is set to
-- Item'First - 1 (or to Stream_Element_Array'Last if Item'First is -- Item'First - 1 when the socket has been closed by peer. This is not
-- Stream_Element_Offset'First) when the socket has been closed by peer. -- an error, and no exception is raised in this case unless Item'First
-- This is not an error and no exception is raised. Flags allows to -- is Stream_Element_Offset'First, in which case Constraint_Error is
-- control the reception. Raise Socket_Error on error. -- raised. Flags allows to control the reception. Raise Socket_Error on
-- error.
procedure Receive_Socket procedure Receive_Socket
(Socket : Socket_Type; (Socket : Socket_Type;
...@@ -937,12 +938,13 @@ package GNAT.Sockets is ...@@ -937,12 +938,13 @@ package GNAT.Sockets is
-- Transmit a message over a socket. For a datagram socket, the address -- Transmit a message over a socket. For a datagram socket, the address
-- is given by To.all. For a stream socket, To must be null. Last -- is given by To.all. For a stream socket, To must be null. Last
-- is the index value such that Item (Last) is the last character -- is the index value such that Item (Last) is the last character
-- sent. Note that Last is set to Item'First - 1 (if Item'First is -- sent. Note that Last is set to Item'First - 1 if the socket has been
-- Stream_Element_Offset'First, to Stream_Element_Array'Last) when the -- closed by the peer (unless Item'First is Stream_Element_Offset'First,
-- socket has been closed by peer. This is not an error and no exception -- in which case Constraint_Error is raised instead). This is not an error,
-- is raised. Flags allows control of the transmission. Raises exception -- and Socket_Error is not raised in that case. Flags allows control of the
-- Socket_Error on error. Note: this subprogram is inlined because it is -- transmission. Raises exception Socket_Error on error. Note: this
-- also used to implement the two variants below. -- subprogram is inlined because it is also used to implement the two
-- variants below.
procedure Send_Socket procedure Send_Socket
(Socket : Socket_Type; (Socket : Socket_Type;
......
...@@ -162,6 +162,12 @@ procedure Gnat1drv is ...@@ -162,6 +162,12 @@ procedure Gnat1drv is
ASIS_Mode := False; ASIS_Mode := False;
-- Disable front-end optimizations, to keep the tree as close to the
-- source code as possible, and also to avoid inconsistencies between
-- trees when using different optimization switches.
Optimization_Level := 0;
-- Disable specific expansions for Restrictions pragmas to avoid -- Disable specific expansions for Restrictions pragmas to avoid
-- tree inconsistencies between compilations with different pragmas -- tree inconsistencies between compilations with different pragmas
-- that will cause different SCIL files to be generated for the -- that will cause different SCIL files to be generated for the
......
...@@ -39,12 +39,14 @@ package body System.Communication is ...@@ -39,12 +39,14 @@ package body System.Communication is
function Last_Index function Last_Index
(First : Ada.Streams.Stream_Element_Offset; (First : Ada.Streams.Stream_Element_Offset;
Count : C.int) return Ada.Streams.Stream_Element_Offset Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset
is is
use type Ada.Streams.Stream_Element_Offset; use type Ada.Streams.Stream_Element_Offset;
use type System.CRTL.size_t;
begin begin
if First = SEO'First and then Count = 0 then if First = SEO'First and then Count = 0 then
return SEO'Last; raise Constraint_Error with
"last index out of range (no element transferred)";
else else
return First + SEO (Count - 1); return First + SEO (Count - 1);
end if; end if;
......
...@@ -32,20 +32,17 @@ ...@@ -32,20 +32,17 @@
-- Common support unit for GNAT.Sockets and GNAT.Serial_Communication -- Common support unit for GNAT.Sockets and GNAT.Serial_Communication
with Ada.Streams; with Ada.Streams;
with Interfaces.C; with System.CRTL;
package System.Communication is package System.Communication is
package C renames Interfaces.C;
use type C.int;
function Last_Index function Last_Index
(First : Ada.Streams.Stream_Element_Offset; (First : Ada.Streams.Stream_Element_Offset;
Count : C.int) return Ada.Streams.Stream_Element_Offset; Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset;
-- Compute the Last OUT parameter for the various Read / Receive -- Compute the Last OUT parameter for the various Read / Receive
-- subprograms: returns First + Count - 1, except for the case -- subprograms: returns First + Count - 1.
-- where First = Stream_Element_Offset'First and Res = 0, in which -- When First = Stream_Element_Offset'First and Res = 0, Constraint_Error
-- case Stream_Element_Offset'Last is returned instead. -- is raised. This is consistent with the semantics of stream operations
-- as clarified in AI95-227.
end System.Communication; end System.Communication;
...@@ -48,6 +48,10 @@ package SCOs is ...@@ -48,6 +48,10 @@ package SCOs is
-- Put_SCO reads the internal tables and generates text lines in the ALI -- Put_SCO reads the internal tables and generates text lines in the ALI
-- format. -- format.
-- ??? The specification below for the SCO ALI format and the internal
-- data structures have been modified, but the implementation has not been
-- updated yet to reflect these specification changes.
-------------------- --------------------
-- SCO ALI Format -- -- SCO ALI Format --
-------------------- --------------------
...@@ -102,31 +106,52 @@ package SCOs is ...@@ -102,31 +106,52 @@ package SCOs is
-- renaming_declaration -- renaming_declaration
-- generic_instantiation -- generic_instantiation
-- and the following regions of the syntax tree:
-- the part of a case_statement from CASE up to the expression
-- the part of a FOR iteration scheme from FOR up to the
-- loop_parameter_specification
-- the part of an extended_return_statement from RETURN up to the
-- expression (if present) or to the return_subtype_indication (if
-- no expression)
-- Statement lines -- Statement lines
-- These lines correspond to a sequence of one or more statements which -- These lines correspond to one or more successive statements (in the
-- are always executed in sequence, The first statement may be an entry -- sense of the above list) which are always executed in sequence (in the
-- point (e.g. statement after a label), and the last statement may be -- absence of exceptions or other external interruptions).
-- an exit point (e.g. an exit statement), but no other entry or exit
-- points may occur within the sequence of statements. The idea is that
-- the sequence can be treated as a single unit from a coverage point of
-- view, if any of the code for the statement sequence is executed, this
-- corresponds to coverage of the entire statement sequence. The form of
-- a statement line in the ALI file is:
-- CS sloc-range -- Entry points to such sequences are:
-- Exit points -- the first statement of any sequence_of_statements
-- the first statement after a compound statement
-- the first statement after an EXIT, RAISE or GOTO statement
-- any statement with a label
-- An exit point is a statement that causes transfer of control. Examples -- Each entry point must appear as the first entry on a CS line.
-- are exit statements, raise statements and return statements. The form -- The idea is that if any simple statement on a CS line is known to have
-- of an exit point in the ALI file is: -- been executed, then all statements that appear before it on the same
-- CS line are certain to also have been executed.
-- CT sloc-range -- The form of a statement line in the ALI file is:
-- Decisions -- CS *sloc-range [*sloc-range...]
-- where each sloc-range corresponds to a single statement, and * is
-- one of:
-- t type declaration
-- s subtype declaration
-- o object declaration
-- r renaming declaration
-- i generic instantiation
-- C CASE statement
-- F FOR loop statement
-- R extended RETURN statement
-- Decisions represent the most significant section of the SCO lines -- and is omitted for all other cases.
-- Decisions
-- Note: in the following description, logical operator includes the -- Note: in the following description, logical operator includes the
-- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN, -- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN,
...@@ -136,7 +161,7 @@ package SCOs is ...@@ -136,7 +161,7 @@ package SCOs is
-- expresssion that occurs in the context of a control structure in the -- expresssion that occurs in the context of a control structure in the
-- source program, including WHILE, IF, EXIT WHEN. Note that a boolean -- source program, including WHILE, IF, EXIT WHEN. Note that a boolean
-- expression in any other context, for example, on the right side of an -- expression in any other context, for example, on the right side of an
-- assignment, is not considered to be a decision. -- assignment, is not considered to be a simple decision.
-- A complex decision is an occurrence of a logical operator which is not -- A complex decision is an occurrence of a logical operator which is not
-- itself an operand of some other logical operator. If any operand of -- itself an operand of some other logical operator. If any operand of
...@@ -160,7 +185,7 @@ package SCOs is ...@@ -160,7 +185,7 @@ package SCOs is
-- For each decision, a decision line is generated with the form: -- For each decision, a decision line is generated with the form:
-- C* expression -- C*sloc expression
-- Here * is one of the following characters: -- Here * is one of the following characters:
...@@ -169,15 +194,23 @@ package SCOs is ...@@ -169,15 +194,23 @@ package SCOs is
-- W decision in WHILE iteration scheme -- W decision in WHILE iteration scheme
-- X decision appearing in some other expression context -- X decision appearing in some other expression context
-- For I, E, W, sloc is the source location of the IF, EXIT or WHILE
-- token.
-- For X, sloc is omitted.
-- The expression is a prefix polish form indicating the structure of -- The expression is a prefix polish form indicating the structure of
-- the decision, including logical operators and short circuit forms. -- the decision, including logical operators and short circuit forms.
-- The following is a grammar showing the structure of expression: -- The following is a grammar showing the structure of expression:
-- expression ::= term (if expr is not logical operator) -- expression ::= term (if expr is not logical operator)
-- expression ::= & term term (if expr is AND or AND THEN) -- expression ::= &sloc term term (if expr is AND or AND THEN)
-- expression ::= | term term (if expr is OR or OR ELSE) -- expression ::= |sloc term term (if expr is OR or OR ELSE)
-- expression ::= ^ term term (if expr is XOR) -- expression ::= ^sloc term term (if expr is XOR)
-- expression ::= !term (if expr is NOT) -- expression ::= !sloc term (if expr is NOT)
-- In the last four cases, sloc is the source location of the AND, OR,
-- XOR or NOT token, respectively.
-- term ::= element -- term ::= element
-- term ::= expression -- term ::= expression
...@@ -194,15 +227,15 @@ package SCOs is ...@@ -194,15 +227,15 @@ package SCOs is
-- the compiler as always being true or false. -- the compiler as always being true or false.
-- & indicates either AND or AND THEN connecting two conditions. In the -- & indicates either AND or AND THEN connecting two conditions. In the
-- context of couverture we only permit AND THEN in the source in any -- context of Couverture we only permit AND THEN in the source in any
-- case, so & can always be understood to be AND THEN. -- case, so & can always be understood to be AND THEN.
-- | indicates either OR or OR ELSE connection two conditions. In the -- | indicates either OR or OR ELSE connection two conditions. In the
-- context of couverture we only permit OR ELSE in the source in any -- context of Couverture we only permit OR ELSE in the source in any
-- case, so | can always be understood to be OR ELSE. -- case, so | can always be understood to be OR ELSE.
-- ^ indicates XOR connecting two conditions. In the context of -- ^ indicates XOR connecting two conditions. In the context of
-- couverture, we do not permit XOR, so this will never appear. -- Couverture, we do not permit XOR, so this will never appear.
-- ! indicates NOT applied to the expression. -- ! indicates NOT applied to the expression.
...@@ -235,41 +268,34 @@ package SCOs is ...@@ -235,41 +268,34 @@ package SCOs is
-- The SCO_Table_Entry values appear as follows: -- The SCO_Table_Entry values appear as follows:
-- Statements -- Statements
-- C1 = 'S' -- C1 = 'S' for entry point, 's' otherwise
-- C2 = ' ' -- C2 = 't', 's', 'o', 'r', 'i', 'C', 'F', 'R', ' '
-- (type/subtype/object/renaming/instantiation/CASE/FOR/RETURN)
-- From = starting source location -- From = starting source location
-- To = ending source location -- To = ending source location
-- Last = unused -- Last = False for all but the last entry, True for last entry
-- Exit
-- C1 = 'T'
-- C2 = ' '
-- From = starting source location
-- To = ending source location
-- Last = unused
-- Simple Decision -- Note: successive statements (possibly interspersed with entries of
-- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression) -- other kinds, that are ignored for this purpose), starting with one
-- C2 = 'c', 't', or 'f' -- labeled with C1 = 'S', up to and including the first one labeled with
-- From = starting source location -- Last=True, indicate the sequence to be output for a sequence of
-- To = ending source location -- statements on a single CS line.
-- Last = True
-- Complex Decision -- Decision
-- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression) -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
-- C2 = ' ' -- C2 = ' '
-- From = No_Source_Location -- From = location of IF/EXIT/WHILE token, No_Source_Location for X
-- To = No_Source_Location -- To = No_Source_Location
-- Last = False -- Last = unused
-- Operator -- Operator
-- C1 = '!', '^', '&', '|' -- C1 = '!', '^', '&', '|'
-- C2 = ' ' -- C2 = ' '
-- From = No_Source_Location -- From = location of NOT/XOR/AND/OR token
-- To = No_Source_Location -- To = No_Source_Location
-- Last = False -- Last = False
-- Element -- Element (condition)
-- C1 = ' ' -- C1 = ' '
-- C2 = 'c', 't', or 'f' (condition/true/false) -- C2 = 'c', 't', or 'f' (condition/true/false)
-- From = starting source location -- From = starting source location
......
...@@ -4000,13 +4000,44 @@ package body Sem_Ch10 is ...@@ -4000,13 +4000,44 @@ package body Sem_Ch10 is
-- If the item is a private with-clause on a child unit, the parent -- If the item is a private with-clause on a child unit, the parent
-- may have been installed already, but the child unit must remain -- may have been installed already, but the child unit must remain
-- invisible until installed in a private part or body. -- invisible until installed in a private part or body, unless there
-- is already a regular with_clause for it in the current unit.
elsif Private_Present (Item) then elsif Private_Present (Item) then
Id := Entity (Name (Item)); Id := Entity (Name (Item));
if Is_Child_Unit (Id) then if Is_Child_Unit (Id) then
Set_Is_Visible_Child_Unit (Id, False); declare
Clause : Node_Id;
function In_Context return Boolean;
-- Scan context of current unit, to check whether there is
-- a with_clause on the same unit as a private with-clause
-- on a parent, in which case child unit is visible.
function In_Context return Boolean is
begin
Clause :=
First (Context_Items (Cunit (Current_Sem_Unit)));
while Present (Clause) loop
if Nkind (Clause) = N_With_Clause
and then Comes_From_Source (Clause)
and then Is_Entity_Name (Name (Clause))
and then Entity (Name (Clause)) = Id
and then not Private_Present (Clause)
then
return True;
end if;
Next (Clause);
end loop;
return False;
end In_Context;
begin
Set_Is_Visible_Child_Unit (Id, In_Context);
end;
end if; end if;
end if; end if;
......
...@@ -2654,10 +2654,13 @@ package body Sem_Ch6 is ...@@ -2654,10 +2654,13 @@ package body Sem_Ch6 is
-- If the type of the first formal of the current subprogram is a -- If the type of the first formal of the current subprogram is a
-- nongeneric tagged private type, mark the subprogram as being a -- nongeneric tagged private type, mark the subprogram as being a
-- private primitive. Ditto if this is a function with controlling -- private primitive. Ditto if this is a function with controlling
-- result, and the return type is currently private. -- result, and the return type is currently private. In both cases,
-- the type of the controlling argument or result must be in the
-- current scope for the operation to be primitive.
if Has_Controlling_Result (Designator) if Has_Controlling_Result (Designator)
and then Is_Private_Type (Etype (Designator)) and then Is_Private_Type (Etype (Designator))
and then Scope (Etype (Designator)) = Current_Scope
and then not Is_Generic_Actual_Type (Etype (Designator)) and then not Is_Generic_Actual_Type (Etype (Designator))
then then
Set_Is_Private_Primitive (Designator); Set_Is_Private_Primitive (Designator);
...@@ -2669,6 +2672,7 @@ package body Sem_Ch6 is ...@@ -2669,6 +2672,7 @@ package body Sem_Ch6 is
begin begin
Set_Is_Private_Primitive (Designator, Set_Is_Private_Primitive (Designator,
Is_Tagged_Type (Formal_Typ) Is_Tagged_Type (Formal_Typ)
and then Scope (Formal_Typ) = Current_Scope
and then Is_Private_Type (Formal_Typ) and then Is_Private_Type (Formal_Typ)
and then not Is_Generic_Actual_Type (Formal_Typ)); and then not Is_Generic_Actual_Type (Formal_Typ));
end; end;
......
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