OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2010-06-21  Robert Dewar  <dewar@adacore.com>

	* s-regpat.adb, s-tpoben.adb, sem_attr.adb, sem_util.adb, sem_util.ads,
	checks.adb, sem_res.adb: Minor reformatting. Add comments.

2010-06-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (New_Overloaded_Entity): If the new entity is a
	rederivation associated with a full declaration in a private part, and
	there is a partial view that derives the same parent subprogram, the
	new entity does not become visible. This check must be applied to
	interface operations as well.

From-SVN: r161078
This commit is contained in:
Arnaud Charlet 2010-06-21 15:44:29 +02:00
parent a548f9ffab
commit 6ca9ec9caf
8 changed files with 141 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -1,3 +1,16 @@
2010-06-21 Robert Dewar <dewar@adacore.com>
* s-regpat.adb, s-tpoben.adb, sem_attr.adb, sem_util.adb, sem_util.ads,
checks.adb, sem_res.adb: Minor reformatting. Add comments.
2010-06-21 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (New_Overloaded_Entity): If the new entity is a
rederivation associated with a full declaration in a private part, and
there is a partial view that derives the same parent subprogram, the
new entity does not become visible. This check must be applied to
interface operations as well.
2010-06-21 Thomas Quinot <quinot@adacore.com>
* checks.adb: Add comments.

1
gcc/ada/checks.adb
View File

@ -6256,6 +6256,7 @@ package body Checks is
-- Returns an attribute reference
-- E'First or E'Last
-- with a source location of Loc.
--
-- Nam is Name_First or Name_Last, according to which attribute is
-- desired. If Indx is non-zero, it is passed as a literal in the
-- Expressions of the attribute reference (identifying the desired

161
gcc/ada/s-regpat.adb
View File

@ -48,7 +48,9 @@ with Ada.Unchecked_Conversion;
package body System.Regpat is
Debug : constant Boolean := False;
-- Set to True to activate debug traces
-- Set to True to activate debug traces. This is normally set to constant
-- False to simply delete all the trace code. It is to be edited to True
-- for internal debugging of the package.
----------------------------
-- Implementation details --
@ -312,16 +314,16 @@ package body System.Regpat is
Till : Pointer;
Indent : Natural;
Do_Print : Boolean := True);
-- Dump the program until the node Till (not included) is met.
-- Every line is indented with Index spaces at the beginning
-- Dumps till the end if Till is 0.
-- Dump the program until the node Till (not included) is met. Every line
-- is indented with Index spaces at the beginning Dumps till the end if
-- Till is 0.
procedure Dump_Operation
(Program : Program_Data;
Index : Pointer;
Indent : Natural);
-- Same as above, but only dumps a single operation, and compute its
-- indentation from the program
-- indentation from the program.
---------
-- "=" --
@ -425,19 +427,19 @@ package body System.Regpat is
(Expr_Flags : out Expression_Flags;
IP : out Pointer);
-- Parse_Atom is the lowest level parse procedure.
-- Optimization: gobbles an entire sequence of ordinary characters
-- so that it can turn them into a single node, which is smaller to
-- store and faster to run. Backslashed characters are exceptions,
-- each becoming a separate node; the code is simpler that way and
-- it's not worth fixing.
--
-- Optimization: Gobbles an entire sequence of ordinary characters so
-- that it can turn them into a single node, which is smaller to store
-- and faster to run. Backslashed characters are exceptions, each
-- becoming a separate node; the code is simpler that way and it's
-- not worth fixing.
procedure Insert_Operator
(Op : Opcode;
Operand : Pointer;
Greedy : Boolean := True);
-- Insert_Operator inserts an operator in front of an
-- already-emitted operand and relocates the operand.
-- This applies to PLUS and STAR.
-- Insert_Operator inserts an operator in front of an already-emitted
-- operand and relocates the operand. This applies to PLUS and STAR.
-- If Minmod is True, then the operator is non-greedy.
function Insert_Operator_Before
@ -446,10 +448,9 @@ package body System.Regpat is
Greedy : Boolean;
Opsize : Pointer) return Pointer;
-- Insert an operator before Operand (and move the latter forward in the
-- program). Opsize is the size needed to represent the operator.
-- This returns the position at which the operator was
-- inserted, and moves Emit_Ptr after the new position of the
-- operand.
-- program). Opsize is the size needed to represent the operator. This
-- returns the position at which the operator was inserted, and moves
-- Emit_Ptr after the new position of the operand.
procedure Insert_Curly_Operator
(Op : Opcode;
@ -543,6 +544,11 @@ package body System.Regpat is
(Character_Class, Program31);
begin
-- What is the mysterious constant 31 here??? Can't it be expressed
-- symbolically (size of integer - 1 or some such???). In any case
-- it should be declared as a constant (and referenced presumably
-- as this constant + 1 below.
if Emit_Ptr + 31 <= PM.Size then
Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap);
end if;
@ -814,22 +820,21 @@ package body System.Regpat is
-- Parse --
-----------
-- Combining parenthesis handling with the base level
-- of regular expression is a trifle forced, but the
-- need to tie the tails of the branches to what follows
-- makes it hard to avoid.
-- Combining parenthesis handling with the base level of regular
-- expression is a trifle forced, but the need to tie the tails of the
-- the branches to what follows makes it hard to avoid.
procedure Parse
(Parenthesized : Boolean;
Flags : out Expression_Flags;
IP : out Pointer)
(Parenthesized : Boolean;
Flags : out Expression_Flags;
IP : out Pointer)
is
E : String renames Expression;
Br, Br2 : Pointer;
Ender : Pointer;
Par_No : Natural;
New_Flags : Expression_Flags;
Have_Branch : Boolean := False;
E : String renames Expression;
Br, Br2 : Pointer;
Ender : Pointer;
Par_No : Natural;
New_Flags : Expression_Flags;
Have_Branch : Boolean := False;
begin
Flags := (Has_Width => True, others => False); -- Tentatively
@ -1982,10 +1987,11 @@ package body System.Regpat is
(Expression : String;
Flags : Regexp_Flags := No_Flags) return Pattern_Matcher
is
-- Assume the compiled regexp will fit in 1000 chars. If it does not
-- we will have to compile a second time once the correct size is
-- known. If it fits, we save a significant amount of time by avoiding
-- the second compilation.
-- Assume the compiled regexp will fit in 1000 chars. If it does not we
-- will have to compile a second time once the correct size is known. If
-- it fits, we save a significant amount of time by avoiding the second
-- compilation.
Dummy : Pattern_Matcher (1000);
Size : Program_Size;
@ -2021,8 +2027,10 @@ package body System.Regpat is
Flags : Regexp_Flags := No_Flags)
is
Size : Program_Size;
begin
Compile (Matcher, Expression, Size, Flags);
if Size > Matcher.Size then
raise Expression_Error with "Pattern_Matcher is too small";
end if;
@ -2033,9 +2041,9 @@ package body System.Regpat is
--------------------
procedure Dump_Operation
(Program : Program_Data;
Index : Pointer;
Indent : Natural)
(Program : Program_Data;
Index : Pointer;
Indent : Natural)
is
Current : Pointer := Index;
begin
@ -2056,6 +2064,10 @@ package body System.Regpat is
function Image (S : String) return String;
-- Remove leading space
-----------
-- Image --
-----------
function Image (S : String) return String is
begin
if S (S'First) = ' ' then
@ -2065,11 +2077,15 @@ package body System.Regpat is
end if;
end Image;
Op : Opcode;
Next : Pointer;
Length : Pointer;
-- Local variables
Op : Opcode;
Next : Pointer;
Length : Pointer;
Local_Indent : Natural := Indent;
-- Start of processing for Dump_Until
begin
while Index < Till loop
Op := Opcode'Val (Character'Pos ((Program (Index))));
@ -2087,8 +2103,8 @@ package body System.Regpat is
-- Print the parenthesis number
if Op = OPEN or else Op = CLOSE or else Op = REFF then
Put
(Image (Natural'Image (Character'Pos (Program (Index + 3)))));
Put (Image (Natural'Image
(Character'Pos (Program (Index + 3)))));
end if;
if Next = Index then
@ -2101,9 +2117,9 @@ package body System.Regpat is
case Op is
when ANYOF =>
declare
Bitmap : Character_Class;
Last : Character := ASCII.NUL;
Current : Natural := 0;
Bitmap : Character_Class;
Last : Character := ASCII.NUL;
Current : Natural := 0;
Current_Char : Character;
begin
@ -2155,8 +2171,8 @@ package body System.Regpat is
Length := String_Length (Program, Index);
if Do_Print then
Put (" (" & Image (Program_Size'Image (Length + 1))
& " chars) <"
& String (Program (String_Operand (Index)
& " chars) <"
& String (Program (String_Operand (Index)
.. String_Operand (Index)
+ Length)));
Put_Line (">");
@ -2440,12 +2456,13 @@ package body System.Regpat is
-------------------
function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
L : constant Natural := Last_Paren;
L : constant Natural := Last_Paren;
Tmp_F : constant Match_Array :=
Matches_Full (From + 1 .. Matches_Full'Last);
Start : constant Natural_Array :=
Matches_Tmp (From + 1 .. Matches_Tmp'Last);
Input : constant Natural := Input_Pos;
Dump_Indent_Save : constant Integer := Dump_Indent;
begin
@ -2467,7 +2484,8 @@ package body System.Regpat is
procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is
Length : constant := 10;
Pos : constant String := Integer'Image (Input_Pos);
Pos : constant String := Integer'Image (Input_Pos);
begin
if Prefix then
Put ((1 .. 5 - Pos'Length => ' '));
@ -2476,9 +2494,11 @@ package body System.Regpat is
.. Integer'Min (Last_In_Data, Input_Pos + Length - 1)));
Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' '));
Put ("> |");
else
Put (" ");
end if;
Dump_Operation (Program, Scan, Indent => Dump_Indent);
end Dump_Current;
@ -2514,8 +2534,8 @@ package body System.Regpat is
Op := Opcode'Val (Character'Pos (Program (Scan)));
-- Calculate offset of next instruction.
-- Second character is most significant in Program_Data.
-- Calculate offset of next instruction. Second character is most
-- significant in Program_Data.
Next := Get_Next (Program, Scan);
@ -2552,7 +2572,7 @@ package body System.Regpat is
when BOL =>
exit State_Machine when Input_Pos /= BOL_Pos
and then ((Self.Flags and Multiple_Lines) = 0
or else Data (Input_Pos - 1) /= ASCII.LF);
or else Data (Input_Pos - 1) /= ASCII.LF);
when MBOL =>
exit State_Machine when Input_Pos /= BOL_Pos
@ -2564,7 +2584,7 @@ package body System.Regpat is
when EOL =>
exit State_Machine when Input_Pos <= Data'Last
and then ((Self.Flags and Multiple_Lines) = 0
or else Data (Input_Pos) /= ASCII.LF);
or else Data (Input_Pos) /= ASCII.LF);
when MEOL =>
exit State_Machine when Input_Pos <= Data'Last
@ -2645,7 +2665,6 @@ package body System.Regpat is
declare
Opnd : Pointer := String_Operand (Scan);
Current : Positive := Input_Pos;
Last : constant Pointer :=
Opnd + String_Length (Program, Scan);
@ -2722,9 +2741,11 @@ package body System.Regpat is
if Last_Paren < No then
Dump_Indent := Dump_Indent - 1;
if Debug then
Dump_Error ("REFF: No match, backtracking");
end if;
return False;
end if;
@ -2735,9 +2756,11 @@ package body System.Regpat is
or else Data (Input_Pos) /= Data (Data_Pos)
then
Dump_Indent := Dump_Indent - 1;
if Debug then
Dump_Error ("REFF: No match, backtracking");
end if;
return False;
end if;
@ -2796,20 +2819,24 @@ package body System.Regpat is
Current_Curly := Cc.Old_Cc;
Dump_Indent := Dump_Indent - 1;
if not Has_Match then
if Debug then
Dump_Error ("CURLYX failed...");
end if;
end if;
return Has_Match;
end;
when WHILEM =>
Result := Match_Whilem;
Dump_Indent := Dump_Indent - 1;
if Debug and then not Result then
Dump_Error ("WHILEM: no match, backtracking");
end if;
return Result;
end case;
@ -2821,8 +2848,8 @@ package body System.Regpat is
Dump_Indent := Dump_Indent - 1;
end if;
-- If we get here, there is no match.
-- For successful matches when EOP is the terminating point.
-- If we get here, there is no match. For successful matches when EOP
-- is the terminating point.
return False;
end Match;
@ -2848,8 +2875,8 @@ package body System.Regpat is
Save : constant Natural := Input_Pos;
begin
-- Lookahead to avoid useless match attempts
-- when we know what character comes next.
-- Lookahead to avoid useless match attempts when we know what
-- character comes next.
if Program (Next) = EXACT then
Next_Char := Program (String_Operand (Next));
@ -2885,10 +2912,12 @@ package body System.Regpat is
if Min /= 0 then
No := Repeat (Operand_Code, Min);
if No < Min then
if Debug then
Dump_Error ("failed... matched" & No'Img & " times");
end if;
return False;
end if;
end if;
@ -2898,6 +2927,7 @@ package body System.Regpat is
-- Find the place where 'next' could work
if Next_Char_Known then
-- Last position to check
if Max = Natural'Last then
@ -2929,8 +2959,8 @@ package body System.Regpat is
return False;
end if;
-- Check that we still match if we stop
-- at the position we just found.
-- Check that we still match if we stop at the position we
-- just found.
declare
Num : constant Natural := Input_Pos - Old;
@ -2982,6 +3012,7 @@ package body System.Regpat is
if Debug then
Dump_Error ("Non-greedy repeat failed...");
end if;
return False;
end if;
end loop;
@ -2998,12 +3029,11 @@ package body System.Regpat is
Dump_Error ("failed... matched" & No'Img & " times");
end if;
-- ??? Perl has some special code here in case the
-- next instruction is of type EOL, since $ and \Z
-- can match before *and* after newline at the end.
-- ??? Perl has some special code here in case the next
-- instruction is of type EOL, since $ and \Z can match before
-- *and* after newline at the end.
-- ??? Perl has some special code here in case (paren)
-- is True.
-- ??? Perl has some special code here in case (paren) is True
-- Else, if we don't have any parenthesis
@ -3039,6 +3069,7 @@ package body System.Regpat is
function Match_Whilem return Boolean is
Cc : constant Current_Curly_Access := Current_Curly;
N : constant Natural := Cc.Cur + 1;
Ln : Natural := 0;

11
gcc/ada/sem_attr.adb
View File

@ -4906,17 +4906,18 @@ package body Sem_Attr is
-----------------------------------
procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
Tsk : Entity_Id;
Tsk : Entity_Id;
-- The concurrent (task or protected) type
begin
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Discriminant
and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
then
Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
if In_Open_Scopes (Tsk)
and then Has_Completion (Tsk)
then
if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
-- Find discriminant of original concurrent type, and use
-- its current discriminal, which is the renaming within
-- the task/protected body.
@ -6015,6 +6016,7 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
else
Check_Concurrent_Discriminant (Lo_Bound);
end if;
@ -6205,6 +6207,7 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;

19
gcc/ada/sem_ch6.adb
View File

@ -7526,9 +7526,11 @@ package body Sem_Ch6 is
-- E exists and is overloadable
else
-- Ada 2005 (AI-251): Derivation of abstract interface primitives
-- need no check against the homonym chain. They are directly added
-- to the list of primitive operations of Derived_Type.
-- Ada 2005 (AI-251): Derivation of abstract interface primitives.
-- They are directly added to the list of primitive operations of
-- Derived_Type, unless this is a rederivation in the private part
-- of an operation that was already derived in the visible part of
-- the current package.
if Ada_Version >= Ada_05
and then Present (Derived_Type)
@ -7536,7 +7538,16 @@ package body Sem_Ch6 is
and then Present (Find_Dispatching_Type (Alias (S)))
and then Is_Interface (Find_Dispatching_Type (Alias (S)))
then
goto Add_New_Entity;
if Type_Conformant (E, S)
and then Is_Package_Or_Generic_Package (Current_Scope)
and then In_Private_Part (Current_Scope)
and then Parent (E) /= Parent (S)
and then Alias (E) = Alias (S)
then
Check_Operation_From_Private_View (S, E);
else
goto Add_New_Entity;
end if;
end if;
Check_Synchronized_Overriding (S, Overridden_Subp);

6
gcc/ada/sem_res.adb
View File

@ -5929,6 +5929,12 @@ package body Sem_Res is
and then In_Open_Scopes (Tsk)
and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
then
-- Note: here Bound denotes a discriminant of the corresponding
-- record type tskV, whose discriminal is a formal of the
-- init-proc tskVIP. What we want is the body discriminal,
-- which is associated to the discriminant of the original
-- concurrent type tsk.
return New_Occurrence_Of
(Find_Body_Discriminal (Entity (Bound)), Loc);

2
gcc/ada/sem_util.adb
View File

@ -3070,9 +3070,11 @@ package body Sem_Util is
(Spec_Discriminant : Entity_Id) return Entity_Id
is
pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
Tsk : constant Entity_Id :=
Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
Disc : Entity_Id;
begin
-- Find discriminant of original concurrent type, and use its current
-- discriminal, which is the renaming within the task/protected body.

2
gcc/ada/sem_util.ads
View File

@ -331,7 +331,7 @@ package Sem_Util is
Typ : Entity_Id) return Entity_Id;
-- Because discriminants may have different names in a generic unit and in
-- an instance, they are resolved positionally when possible. A reference
-- to a discriminant carries the discriminant that it denotes when
-- to a discriminant carries the discriminant that it denotes when it is
-- analyzed. Subsequent uses of this id on a different type denotes the
-- discriminant at the same position in this new type.