+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.
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.
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 *,
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 */
-- 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>;
-- . . .
-- begin
-- loop
-- <original source statements with attribute rewrites>
- -- exit when not <Condition>;
+ -- exit when not Fnn;
-- end loop;
-- end;
-- end if;
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);
-- 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
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
Analyze (Temp_Decl);
end if;
+ Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
Analyze (N);
if not Installed then
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
-- 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
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
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
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));
-- 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
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;
function Size (File : File_Type) return Count is
Pos : int64;
+
begin
FIO.Check_File_Open (AP (File));
File.Last_Op := Op_Other;
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;
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 "
(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;
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
-- 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;
("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
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
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
then
Illegal_Indexing
("Indexing aspect cannot be specified on full view "
- & "if partial view is tagged");
+ & "if partial view is tagged");
return;
end if;
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);
-- 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
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
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));
projects / thirdparty / gcc.git / commitdiff
