diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 38 | ||||
| -rw-r--r-- | gcc/ada/adaint.h | 6 | ||||
| -rw-r--r-- | gcc/ada/cstreams.c | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 92 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 29 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/s-direio.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 2 |
11 files changed, 191 insertions, 96 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6f0cda8e348..deed861a34c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 2330a794515..6db5bab65ad 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -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 *, diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c index 3de270f942f..a58d9e5f76e 100644 --- a/gcc/ada/cstreams.c +++ b/gcc/ada/cstreams.c @@ -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 */ diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 97ed8874b51..6bc73b7013b 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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 diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 5b7447c5fb8..a91380f7425 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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)); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index b4346a63c85..c92d0aa9d46 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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 diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb index 297454e471c..e4ccf364064 100644 --- a/gcc/ada/s-direio.adb +++ b/gcc/ada/s-direio.adb @@ -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; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 709a2647f7d..e00b567e7ba 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -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 " diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 36378621849..09621e7a171 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4610fe01432..9685d7500f4 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ff3f1ecb464..19b32352314 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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)); |