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

[multiple changes] 

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor
	reformatting.

2014-07-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_attr.adb (Expand_Loop_Entry_Attribute): Update the comment
	which demonstrates the expansion of while loops subject to
	attribute 'Loop_Entry. The condition of a while loop along with
	related condition actions is now wrapped in a function.  Instead
	of repeating the condition, the expansion now calls the function.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_case.adb (Check_Against_Predicate): Correct off-by-one
	error when reporting of missing values in a case statement for
	a type with a static predicate.
	(Check_Choices): Reject a choice given by a subtype to which a
	Dynamic_Predicate applies.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Inherit
	Has_Dynamic_Predicate_Aspect flag from parent.

2014-07-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): A predicate
	cannot apply to a subtype of an incomplete type.
	(Is_Static_Choice): Treat an Others_Clause as static. The
	staticness of the expression and of the range are checked
	elsewhere.

2014-07-31  Pascal Obry  <obry@adacore.com>

	* adaint.h (__gnat_ftell64): Added.
	(__gnat_fseek64): Added.
	(__int64): Added.
	* cstreams.c (__int64): Removed.

From-SVN: r213366
This commit is contained in:
Arnaud Charlet 2014-07-31 15:31:48 +02:00
parent d1e0e1480b
commit fd7215d711
11 changed files with 191 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
gcc/ada/ChangeLog
View File

@ -1,3 +1,41 @@
2014-07-31 Robert Dewar <dewar@adacore.com>
* exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor
reformatting.
2014-07-31 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb (Expand_Loop_Entry_Attribute): Update the comment
which demonstrates the expansion of while loops subject to
attribute 'Loop_Entry. The condition of a while loop along with
related condition actions is now wrapped in a function. Instead
of repeating the condition, the expansion now calls the function.
2014-07-31 Ed Schonberg <schonberg@adacore.com>
* sem_case.adb (Check_Against_Predicate): Correct off-by-one
error when reporting of missing values in a case statement for
a type with a static predicate.
(Check_Choices): Reject a choice given by a subtype to which a
Dynamic_Predicate applies.
* sem_ch3.adb (Analyze_Subtype_Declaration): Inherit
Has_Dynamic_Predicate_Aspect flag from parent.
2014-07-31 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): A predicate
cannot apply to a subtype of an incomplete type.
(Is_Static_Choice): Treat an Others_Clause as static. The
staticness of the expression and of the range are checked
elsewhere.
2014-07-31 Pascal Obry <obry@adacore.com>
* adaint.h (__gnat_ftell64): Added.
(__gnat_fseek64): Added.
(__int64): Added.
* cstreams.c (__int64): Removed.
2014-07-31 Pascal Obry <obry@adacore.com>
* a-stream.ads (Stream_Element_Offset): Now a signed 64bit type.

6
gcc/ada/adaint.h
View File

@ -72,6 +72,8 @@ typedef long long OS_Time;
typedef long OS_Time;
#endif
#define __int64 long long
/* A lazy cache for the attributes of a file. On some systems, a single call to
stat() will give all this information, so it is better than doing a system
call every time. On other systems this require several system calls.
@ -251,6 +253,10 @@ extern int __gnat_set_close_on_exec (int, int);
extern int __gnat_dup (int);
extern int __gnat_dup2 (int, int);
/* large file support */
extern __int64 __gnat_ftell64 (FILE *);
extern int __gnat_fseek64 (FILE *, __int64, int);
extern int __gnat_number_of_cpus (void);
extern void __gnat_os_filename (char *, char *, char *,

2
gcc/ada/cstreams.c
View File

@ -253,8 +253,6 @@ __gnat_full_name (char *nam, char *buffer)
return buffer;
}
#define __int64 long long
#ifdef _WIN32
/* On Windows we want to use the fseek/fteel supporting large files. This
issue is due to the fact that a long on Win64 is still a 32 bits value */

92
gcc/ada/exp_attr.adb
View File

@ -1120,7 +1120,13 @@ package body Exp_Attr is
-- While loops are transformed into:
-- if <Condition> then
-- function Fnn return Boolean is
-- begin
-- <condition actions>
-- return <condition>;
-- end Fnn;
-- if Fnn then
-- declare
-- Temp1 : constant <type of Pref1> := <Pref1>;
-- . . .
@ -1128,7 +1134,7 @@ package body Exp_Attr is
-- begin
-- loop
-- <original source statements with attribute rewrites>
-- exit when not <Condition>;
-- exit when not Fnn;
-- end loop;
-- end;
-- end if;
@ -1138,23 +1144,81 @@ package body Exp_Attr is
elsif Present (Condition (Scheme)) then
declare
Cond : constant Node_Id := Condition (Scheme);
Func_Decl : Node_Id;
Func_Id : Entity_Id;
Stmts : List_Id;
begin
-- Wrap the condition of the while loop in a Boolean function.
-- This avoids the duplication of the same code which may lead
-- to gigi issues with respect to multiple declaration of the
-- same entity in the presence of side effects or checks. Note
-- that the condition actions must also be relocated to the
-- wrapping function.
-- Generate:
-- <condition actions>
-- return <condition>;
if Present (Condition_Actions (Scheme)) then
Stmts := Condition_Actions (Scheme);
else
Stmts := New_List;
end if;
Append_To (Stmts,
Make_Simple_Return_Statement (Loc,
Expression => Relocate_Node (Condition (Scheme))));
-- Generate:
-- function Fnn return Boolean is
-- begin
-- <Stmts>
-- end Fnn;
Func_Id := Make_Temporary (Loc, 'F');
Func_Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
-- The function is inserted before the related loop. Make sure
-- to analyze it in the context of the loop's enclosing scope.
Push_Scope (Scope (Loop_Id));
Insert_Action (Loop_Stmt, Func_Decl);
Pop_Scope;
-- Transform the original while loop into an infinite loop
-- where the last statement checks the negated condition. This
-- placement ensures that the condition will not be evaluated
-- twice on the first iteration.
Set_Iteration_Scheme (Loop_Stmt, Empty);
Scheme := Empty;
-- Generate:
-- exit when not <Cond>:
-- exit when not Fnn;
Append_To (Statements (Loop_Stmt),
Make_Exit_Statement (Loc,
Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond))));
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Func_Id, Loc)))));
Build_Conditional_Block (Loc,
Cond => Relocate_Node (Cond),
Cond =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Func_Id, Loc)),
Loop_Stmt => Relocate_Node (Loop_Stmt),
If_Stmt => Result,
Blk_Stmt => Blk);
@ -1289,8 +1353,6 @@ package body Exp_Attr is
-- Step 4: Analyze all bits
Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
Installed := Current_Scope = Scope (Loop_Id);
-- Depending on the pracement of attribute 'Loop_Entry relative to the
@ -1305,19 +1367,6 @@ package body Exp_Attr is
if Present (Result) then
Rewrite (Loop_Stmt, Result);
-- The insertion of condition actions associated with an iteration
-- scheme is usually done by the expansion of loop statements. The
-- expansion of Loop_Entry however reuses the iteration scheme to
-- build an if statement. As a result any condition actions must be
-- inserted before the if statement to avoid references before
-- declaration.
if Present (Scheme) and then Present (Condition_Actions (Scheme)) then
Insert_Actions (Loop_Stmt, Condition_Actions (Scheme));
Set_Condition_Actions (Scheme, No_List);
end if;
Analyze (Loop_Stmt);
-- The conditional block was analyzed when a previous 'Loop_Entry was
@ -1328,6 +1377,7 @@ package body Exp_Attr is
Analyze (Temp_Decl);
end if;
Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
Analyze (N);
if not Installed then

29
gcc/ada/exp_util.adb
View File

@ -3325,7 +3325,6 @@ package body Exp_Util is
function Has_Annotate_Pragma_For_External_Axiomatization
(E : Entity_Id) return Boolean
is
function Is_Annotate_Pragma_For_External_Axiomatization
(N : Node_Id) return Boolean;
-- Returns whether N is
@ -3352,15 +3351,14 @@ package body Exp_Util is
-- pragma Annotate (GNATprove, External_Axiomatization);
function Is_Annotate_Pragma_For_External_Axiomatization
(N : Node_Id) return Boolean is
-------------------
-- Special Names --
-------------------
Name_GNATprove : constant String := "gnatprove";
(N : Node_Id) return Boolean
is
Name_GNATprove : constant String :=
"gnatprove";
Name_External_Axiomatization : constant String :=
"external_axiomatization";
"external_axiomatization";
-- Special names
begin
if Nkind (N) = N_Pragma
and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate
@ -3368,10 +3366,11 @@ package body Exp_Util is
then
declare
Arg1 : constant Node_Id :=
First (Pragma_Argument_Associations (N));
First (Pragma_Argument_Associations (N));
Arg2 : constant Node_Id := Next (Arg1);
Nam1 : Name_Id;
Nam2 : Name_Id;
begin
-- Fill in Name_Buffer with Name_GNATprove first, and then with
-- Name_External_Axiomatization so that Name_Find returns the
@ -3386,8 +3385,8 @@ package body Exp_Util is
Nam2 := Name_Find;
return Chars (Get_Pragma_Arg (Arg1)) = Nam1
and then
Chars (Get_Pragma_Arg (Arg2)) = Nam2;
and then
Chars (Get_Pragma_Arg (Arg2)) = Nam2;
end;
else
@ -3395,10 +3394,14 @@ package body Exp_Util is
end if;
end Is_Annotate_Pragma_For_External_Axiomatization;
Decl : Node_Id;
-- Local variables
Decl : Node_Id;
Vis_Decls : List_Id;
N : Node_Id;
-- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
begin
if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
Decl := Parent (Parent (E));

3
gcc/ada/lib-writ.adb
View File

@ -662,8 +662,7 @@ package body Lib.Writ is
-- compilation unit.
begin
if U /= No_Unit
and then Nkind (Unit (Cunit (U))) = N_Subunit
if U /= No_Unit and then Nkind (Unit (Cunit (U))) = N_Subunit
then
Note_Unit := Main_Unit;
else

6
gcc/ada/s-direio.adb
View File

@ -282,8 +282,9 @@ package body System.Direct_IO is
procedure Set_Position (File : File_Type) is
R : int;
begin
R := fseek64
(File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET);
R :=
fseek64
(File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET);
if R /= 0 then
raise Use_Error;
@ -296,6 +297,7 @@ package body System.Direct_IO is
function Size (File : File_Type) return Count is
Pos : int64;
begin
FIO.Check_File_Open (AP (File));
File.Last_Op := Op_Other;

4
gcc/ada/sem_case.adb
View File

@ -433,9 +433,10 @@ package body Sem_Case is
Error := True;
-- The previous choice covered part of the static predicate set
-- but there is a gap after Prev_Hi.
else
Missing_Choice (Prev_Hi, Choice_Lo - 1);
Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
Error := True;
end if;
end if;
@ -1462,6 +1463,7 @@ package body Sem_Case is
if not Is_Discrete_Type (E)
or else not Has_Static_Predicate (E)
or else Has_Dynamic_Predicate_Aspect (E)
then
Bad_Predicated_Subtype_Use
("cannot use subtype& with non-static "

80
gcc/ada/sem_ch12.adb
View File

@ -1018,17 +1018,17 @@ package body Sem_Ch12 is
(Formal : Entity_Id;
Actual : Entity_Id := Empty) return Node_Id
is
Loc : constant Source_Ptr := Sloc (I_Node);
Typ : constant Entity_Id := Etype (Formal);
Loc : constant Source_Ptr := Sloc (I_Node);
Typ : constant Entity_Id := Etype (Formal);
Is_Binary : constant Boolean :=
Present (Next_Formal (First_Formal (Formal)));
Present (Next_Formal (First_Formal (Formal)));
Decl : Node_Id;
Expr : Node_Id;
F1, F2 : Entity_Id;
Func : Entity_Id;
Decl : Node_Id;
Expr : Node_Id;
F1, F2 : Entity_Id;
Func : Entity_Id;
Op_Name : Name_Id;
Spec : Node_Id;
Spec : Node_Id;
L, R : Node_Id;
@ -1050,23 +1050,24 @@ package body Sem_Ch12 is
Set_Ekind (Func, E_Function);
Set_Is_Generic_Actual_Subprogram (Func);
Spec := Make_Function_Specification (Loc,
Defining_Unit_Name => Func,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => F1,
Parameter_Type => Make_Identifier
(Loc, Chars (Etype (First_Formal (Formal)))))),
Result_Definition => Make_Identifier (Loc, Chars (Typ)));
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Func,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => F1,
Parameter_Type =>
Make_Identifier (Loc,
Chars => Chars (Etype (First_Formal (Formal)))))),
Result_Definition => Make_Identifier (Loc, Chars (Typ)));
if Is_Binary then
Append_To (Parameter_Specifications (Spec),
Make_Parameter_Specification (Loc,
Defining_Identifier => F2,
Parameter_Type => Make_Identifier (Loc,
Chars (Etype (Next_Formal (First_Formal (Formal)))))));
Parameter_Type =>
Make_Identifier (Loc,
Chars (Etype (Next_Formal (First_Formal (Formal)))))));
end if;
-- Build expression as a function call, or as an operator node
@ -1074,86 +1075,73 @@ package body Sem_Ch12 is
-- operators.
if Present (Actual) and then Op_Name not in Any_Operator_Name then
Expr := Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Actual), Loc),
Parameter_Associations => New_List (L));
Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Entity (Actual), Loc),
Parameter_Associations => New_List (L));
if Is_Binary then
Append_To (Parameter_Associations (Expr), R);
end if;
-- Binary operators
elsif Is_Binary then
if Op_Name = Name_Op_And then
Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Or then
Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Xor then
Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Eq then
Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Ne then
Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Le then
Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Gt then
Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Ge then
Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Lt then
Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Add then
Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Subtract then
Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Concat then
Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Multiply then
Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Divide then
Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Mod then
Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Rem then
Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R);
elsif Op_Name = Name_Op_Expon then
Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R);
end if;
else -- Unary operators.
-- Unary operators
else
if Op_Name = Name_Op_Add then
Expr := Make_Op_Plus (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Subtract then
Expr := Make_Op_Minus (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Abs then
Expr := Make_Op_Abs (Loc, Right_Opnd => L);
elsif Op_Name = Name_Op_Not then
Expr := Make_Op_Not (Loc, Right_Opnd => L);
end if;
end if;
Decl := Make_Expression_Function (Loc,
Specification => Spec,
Expression => Expr);
Decl :=
Make_Expression_Function (Loc,
Specification => Spec,
Expression => Expr);
return Decl;
end Build_Wrapper;

25
gcc/ada/sem_ch13.adb
View File

@ -1787,6 +1787,11 @@ package body Sem_Ch13 is
("predicate can only be specified for a subtype",
Aspect);
goto Continue;
elsif Is_Incomplete_Type (E) then
Error_Msg_N
("predicate cannot apply to incomplete view", Aspect);
goto Continue;
end if;
-- Construct the pragma (always a pragma Predicate, with
@ -3544,8 +3549,9 @@ package body Sem_Ch13 is
if Ekind (Current_Scope) = E_Package
and then Has_Private_Declaration (Ent)
and then From_Aspect_Specification (N)
and then List_Containing (Parent (Ent))
= Private_Declarations
and then
List_Containing (Parent (Ent)) =
Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Nkind (N) = N_Attribute_Definition_Clause
then
@ -3555,8 +3561,8 @@ package body Sem_Ch13 is
begin
Decl :=
First (Visible_Declarations
(Specification
(Unit_Declaration_Node (Current_Scope))));
(Specification
(Unit_Declaration_Node (Current_Scope))));
while Present (Decl) loop
if Nkind (Decl) = N_Private_Type_Declaration
@ -3566,7 +3572,7 @@ package body Sem_Ch13 is
then
Illegal_Indexing
("Indexing aspect cannot be specified on full view "
& "if partial view is tagged");
& "if partial view is tagged");
return;
end if;
@ -3678,9 +3684,7 @@ package body Sem_Ch13 is
end;
end if;
if not Indexing_Found
and then not Error_Posted (N)
then
if not Indexing_Found and then not Error_Posted (N) then
Error_Msg_NE
("aspect Indexing requires a local function that "
& "applies to type&", Expr, Ent);
@ -10618,6 +10622,8 @@ package body Sem_Ch13 is
-- Returns true if all elements of the list are OK static choices
-- as defined below for Is_Static_Choice. Used for case expression
-- alternatives and for the right operand of a membership test.
-- An others_choice is static if the corresponding expression is static.
-- The staticness of the bounds is checked separately.
function Is_Static_Choice (N : Node_Id) return Boolean;
-- Returns True if N represents a static choice (static subtype, or
@ -10683,7 +10689,8 @@ package body Sem_Ch13 is
function Is_Static_Choice (N : Node_Id) return Boolean is
begin
return Is_OK_Static_Expression (N)
return Nkind (N) = N_Others_Choice
or else Is_OK_Static_Expression (N)
or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
and then Is_OK_Static_Subtype (Entity (N)))
or else (Nkind (N) = N_Subtype_Indication

2
gcc/ada/sem_ch3.adb
View File

@ -4514,6 +4514,8 @@ package body Sem_Ch3 is
when Enumeration_Kind =>
Set_Ekind (Id, E_Enumeration_Subtype);
Set_Has_Dynamic_Predicate_Aspect (Id,
Has_Dynamic_Predicate_Aspect (T));
Set_First_Literal (Id, First_Literal (Base_Type (T)));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));