+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>
* s-oscons-tmplt.c [__mips && __sgi]: Only define _XOPEN5, IOV_MAX
-- --
------------------------------------------------------------------------------
-with Interfaces.C_Streams; use Interfaces.C_Streams;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
+with System.Communication; use System.Communication;
with System.File_IO;
with System.Soft_Links;
with System.CRTL;
end if;
File.Index := File.Index + Count (Nread);
- Last := Item'First + Stream_Element_Offset (Nread) - 1;
File.Last_Op := Op_Read;
+ Last := Last_Index (Item'First, Nread);
end Read;
-- This version of Read is the primitive operation on the underlying
-- 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
-- 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)
-- Present in all entities. Set true for a scope that contains the
-- child unit, or if it is the descendent of a private child unit.
-- Is_Private_Primitive (Flag245)
--- Present in subprograms. Set if the first parameter of the subprogram
--- is of concurrent tagged type with a private view.
+-- Present in subprograms. Set if the operation is a primitive of a
+-- 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)
-- Applies to all entities, true for private types and subtypes,
is
Def : Node_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
if Is_Protected_Type (Typ) then
Rec_Typ := Corresponding_Record_Type (Typ);
-- 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))
and then Present (Def)
- and then Present (Visible_Declarations (Def))
then
- declare
- Decl : Node_Id;
- 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;
+ Scan_Declarations (Visible_Declarations (Def));
+ Scan_Declarations (Private_Declarations (Def));
end if;
end Build_Wrapper_Specs;
Raise_Error ("read failed");
end if;
- Last := Last_Index (Buffer'First, C.int (Res));
+ Last := Last_Index (Buffer'First, size_t (Res));
end Read;
---------
with System; use System;
with System.Communication; use System.Communication;
+with System.CRTL; use System.CRTL;
with System.Win32; use System.Win32;
with System.Win32.Ext; use System.Win32.Ext;
Raise_Error ("read error");
end if;
- Last := Last_Index (Buffer'First, C.int (Read_Last));
+ Last := Last_Index (Buffer'First, size_t (Read_Last));
end Read;
---------
Last : out Ada.Streams.Stream_Element_Offset);
-- 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
- -- Buffer'First = Stream_Element_Offset'First, in which case Last is
- -- set to Stream_Element_Offset'Last instead.
+ -- Buffer'First = Stream_Element_Offset'First, in which case
+ -- Constraint_Error raised instead.
overriding procedure Write
(Port : in out Serial_Port;
with System; use System;
with System.Communication; use System.Communication;
+with System.CRTL; use System.CRTL;
package body GNAT.Sockets is
Raise_Socket_Error (Socket_Errno);
end if;
- Last := Last_Index (First => Item'First, Count => Res);
+ Last := Last_Index (First => Item'First, Count => size_t (Res));
end Receive_Socket;
--------------------
Raise_Socket_Error (Socket_Errno);
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);
From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
Raise_Socket_Error (Socket_Errno);
end if;
- Last := Last_Index (First => Item'First, Count => Res);
+ Last := Last_Index (First => Item'First, Count => size_t (Res));
end Send_Socket;
-----------------
Flags : Request_Flag_Type := No_Request_Flag);
-- Receive message from Socket. Last is the index value such that Item
-- (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
- -- Stream_Element_Offset'First) when the socket has been closed by peer.
- -- This is not an error and no exception is raised. Flags allows to
- -- control the reception. Raise Socket_Error on error.
+ -- Item'First - 1 when the socket has been closed by peer. This is not
+ -- an error, and no exception is raised in this case unless Item'First
+ -- is Stream_Element_Offset'First, in which case Constraint_Error is
+ -- raised. Flags allows to control the reception. Raise Socket_Error on
+ -- error.
procedure Receive_Socket
(Socket : Socket_Type;
-- 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 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
- -- Stream_Element_Offset'First, to Stream_Element_Array'Last) when the
- -- socket has been closed by peer. This is not an error and no exception
- -- is raised. Flags allows control of the transmission. Raises exception
- -- Socket_Error on error. Note: this subprogram is inlined because it is
- -- also used to implement the two variants below.
+ -- sent. Note that Last is set to Item'First - 1 if the socket has been
+ -- closed by the peer (unless Item'First is Stream_Element_Offset'First,
+ -- in which case Constraint_Error is raised instead). This is not an error,
+ -- and Socket_Error is not raised in that case. Flags allows control of the
+ -- transmission. Raises exception Socket_Error on error. Note: this
+ -- subprogram is inlined because it is also used to implement the two
+ -- variants below.
procedure Send_Socket
(Socket : Socket_Type;
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
-- tree inconsistencies between compilations with different pragmas
-- that will cause different SCIL files to be generated for the
function Last_Index
(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
use type Ada.Streams.Stream_Element_Offset;
+ use type System.CRTL.size_t;
begin
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
return First + SEO (Count - 1);
end if;
-- Common support unit for GNAT.Sockets and GNAT.Serial_Communication
with Ada.Streams;
-with Interfaces.C;
+with System.CRTL;
package System.Communication is
- package C renames Interfaces.C;
-
- use type C.int;
-
function Last_Index
(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
- -- subprograms: returns First + Count - 1, except for the case
- -- where First = Stream_Element_Offset'First and Res = 0, in which
- -- case Stream_Element_Offset'Last is returned instead.
+ -- subprograms: returns First + Count - 1.
+ -- When First = Stream_Element_Offset'First and Res = 0, Constraint_Error
+ -- is raised. This is consistent with the semantics of stream operations
+ -- as clarified in AI95-227.
end System.Communication;
-- Put_SCO reads the internal tables and generates text lines in the ALI
-- 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 --
--------------------
-- renaming_declaration
-- 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
- -- These lines correspond to a sequence of one or more statements which
- -- are always executed in sequence, The first statement may be an entry
- -- point (e.g. statement after a label), and the last statement may be
- -- 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:
+ -- These lines correspond to one or more successive statements (in the
+ -- sense of the above list) which are always executed in sequence (in the
+ -- absence of exceptions or other external interruptions).
- -- 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
- -- are exit statements, raise statements and return statements. The form
- -- of an exit point in the ALI file is:
+ -- Each entry point must appear as the first entry on a CS line.
+ -- The idea is that if any simple statement on a CS line is known to have
+ -- 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
-- short circuited forms (so can be any of AND, OR, XOR, NOT, AND THEN,
-- expresssion that occurs in the context of a control structure in the
-- source program, including WHILE, IF, EXIT WHEN. Note that a boolean
-- 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
-- itself an operand of some other logical operator. If any operand of
-- For each decision, a decision line is generated with the form:
- -- C* expression
+ -- C*sloc expression
-- Here * is one of the following characters:
-- W decision in WHILE iteration scheme
-- 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 decision, including logical operators and short circuit forms.
-- The following is a grammar showing the structure of expression:
-- expression ::= term (if expr is not logical operator)
- -- expression ::= & term term (if expr is AND or AND THEN)
- -- expression ::= | term term (if expr is OR or OR ELSE)
- -- expression ::= ^ term term (if expr is XOR)
- -- expression ::= !term (if expr is NOT)
+ -- expression ::= &sloc term term (if expr is AND or AND THEN)
+ -- expression ::= |sloc term term (if expr is OR or OR ELSE)
+ -- expression ::= ^sloc term term (if expr is XOR)
+ -- 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 ::= expression
-- the compiler as always being true or false.
-- & 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.
-- | 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.
-- ^ 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.
-- The SCO_Table_Entry values appear as follows:
-- Statements
- -- C1 = 'S'
- -- C2 = ' '
+ -- C1 = 'S' for entry point, 's' otherwise
+ -- C2 = 't', 's', 'o', 'r', 'i', 'C', 'F', 'R', ' '
+ -- (type/subtype/object/renaming/instantiation/CASE/FOR/RETURN)
-- From = starting source location
-- To = ending source location
- -- Last = unused
-
- -- Exit
- -- C1 = 'T'
- -- C2 = ' '
- -- From = starting source location
- -- To = ending source location
- -- Last = unused
+ -- Last = False for all but the last entry, True for last entry
- -- Simple Decision
- -- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
- -- C2 = 'c', 't', or 'f'
- -- From = starting source location
- -- To = ending source location
- -- Last = True
+ -- Note: successive statements (possibly interspersed with entries of
+ -- other kinds, that are ignored for this purpose), starting with one
+ -- labeled with C1 = 'S', up to and including the first one labeled with
+ -- Last=True, indicate the sequence to be output for a sequence of
+ -- statements on a single CS line.
- -- Complex Decision
+ -- Decision
-- C1 = 'I', 'E', 'W', 'X' (if/exit/while/expression)
-- C2 = ' '
- -- From = No_Source_Location
+ -- From = location of IF/EXIT/WHILE token, No_Source_Location for X
-- To = No_Source_Location
- -- Last = False
+ -- Last = unused
-- Operator
-- C1 = '!', '^', '&', '|'
-- C2 = ' '
- -- From = No_Source_Location
+ -- From = location of NOT/XOR/AND/OR token
-- To = No_Source_Location
-- Last = False
- -- Element
+ -- Element (condition)
-- C1 = ' '
-- C2 = 'c', 't', or 'f' (condition/true/false)
-- From = starting source location
-- 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
- -- 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
Id := Entity (Name (Item));
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;
-- If the type of the first formal of the current subprogram is a
-- nongeneric tagged private type, mark the subprogram as being a
-- 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)
and then Is_Private_Type (Etype (Designator))
+ and then Scope (Etype (Designator)) = Current_Scope
and then not Is_Generic_Actual_Type (Etype (Designator))
then
Set_Is_Private_Primitive (Designator);
begin
Set_Is_Private_Primitive (Designator,
Is_Tagged_Type (Formal_Typ)
+ and then Scope (Formal_Typ) = Current_Scope
and then Is_Private_Type (Formal_Typ)
and then not Is_Generic_Actual_Type (Formal_Typ));
end;
OSDN Git Service
