+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.adb (Overridden_Operation): assert that
+ function is called for valid arguments.
+ * sem_aggr.adb, sem_ch3.adb, sem_ch5.adb, sem_type.adb,
+ s-osinte-vxworks.ads, a-ngcefu.adb, sem_ch10.adb, einfo.ads,
+ sem_prag.adb, sem_ch12.adb, sem.adb, i-cobol.ads, freeze.adb,
+ sem_util.adb, a-chtgop.ads, s-rannum.adb, exp_ch6.adb, s-bignum.adb,
+ s-osinte-freebsd.ads, par-ch5.adb, a-chtgbo.ads, a-cofove.adb:
+ No space after closing parenthesis except where required for
+ layout.
+ * sem_res.adb: Minor reformatting.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Case_Expression): Convert into a case
+ statement when relevant.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.adb (Enqueue): Properly handle the
+ case where the new element has a unique priority.
+
+2016-04-18 Tristan Gingold <gingold@adacore.com>
+
+ * adaint.h: Define stat structures and functions for iOS
+ simulator.
+
2016-04-18 Arnaud Charlet <charlet@adacore.com>
* sem_res.adb (Resolve_Entry_Call): reset
procedure Clear (HT : in out Hash_Table_Type'Class);
-- Deallocates each node in hash table HT. (Note that it only deallocates
- -- the nodes, not the buckets array.) Program_Error is raised if the hash
+ -- the nodes, not the buckets array.) Program_Error is raised if the hash
-- table is busy.
procedure Delete_Node_At_Index
procedure Clear (HT : in out Hash_Table_Type);
-- Deallocates each node in hash table HT. (Note that it only deallocates
- -- the nodes, not the buckets array.) Program_Error is raised if the hash
+ -- the nodes, not the buckets array.) Program_Error is raised if the hash
-- table is busy.
procedure Move (Target, Source : in out Hash_Table_Type);
procedure Append (Container : in out Vector; New_Item : Vector) is
begin
- for X in First_Index (New_Item) .. Last_Index (New_Item) loop
+ for X in First_Index (New_Item) .. Last_Index (New_Item) loop
Append (Container, Element (New_Item, X));
end loop;
end Append;
raise Constraint_Error with "vector is already at its maximum length";
end if;
- -- TODO: should check whether length > max capacity (cnt_t'last) ???
+ -- TODO: should check whether length > max capacity (cnt_t'last) ???
Container.Last := Container.Last + 1;
Elems (Container) (Length (Container)) := New_Item;
-- must update.
List.Header.Next_Unequal := Node;
+
+ elsif Before (Get_Priority (Prev.Element), P) then
+
+ -- If the new item inserted has a unique priority in queue (not
+ -- same priority as precedent), set Next_Unequal of precedent
+ -- element to the new element instead of old next element, since
+ -- Before (P, Get_Priority (Next.Element) or Next = H).
+
+ Prev.Next_Unequal := Node;
end if;
pragma Assert (List.Header.Next_Unequal = List.Header.Next);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
return Left;
- elsif Right = (0.0, 0.0) then
+ elsif Right = (0.0, 0.0) then
return Complex_One;
elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
begin
return
Compose_From_Cartesian
- (Cos (Re (X)) * Cosh (Im (X)),
+ (Cos (Re (X)) * Cosh (Im (X)),
-(Sin (Re (X)) * Sinh (Im (X))));
end Cos;
#define GNAT_LSTAT lstat
#define GNAT_STRUCT_STAT struct stat64
+#elif defined(__APPLE__)
+
+# include <TargetConditionals.h>
+
+# if TARGET_IPHONE_SIMULATOR
+ /* On iOS (simulator or not), the stat structure is the 64 bit one.
+ But the simulator uses the MacOS X syscalls that aren't 64 bit.
+ Fix this interfacing issue here. */
+ int fstat64(int, struct stat *);
+ int stat64(const char *, struct stat *);
+ int lstat64(const char *, struct stat *);
+# define GNAT_STAT stat64
+# define GNAT_FSTAT fstat64
+# define GNAT_LSTAT lstat64
+# else
+# define GNAT_STAT stat
+# define GNAT_FSTAT fstat
+# define GNAT_LSTAT lstat
+# endif
+
+# define GNAT_FOPEN fopen
+# define GNAT_OPEN open
+# define GNAT_STRUCT_STAT struct stat
+
#else
#define GNAT_FOPEN fopen
#define GNAT_OPEN open
function Is_Predicate_Function (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag255 (Id);
end Is_Predicate_Function;
function Is_Predicate_Function_M (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag256 (Id);
end Is_Predicate_Function_M;
function Overridden_Operation (Id : E) return E is
begin
+ pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
return Node26 (Id);
end Overridden_Operation;
procedure Set_Is_Predicate_Function (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag255 (Id, V);
end Set_Is_Predicate_Function;
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag256 (Id, V);
end Set_Is_Predicate_Function_M;
-- Needs_No_Actuals (Flag22)
-- Defined in callable entities (subprograms, entries, access to
--- subprograms) which can be called without actuals because all of
+-- subprograms) which can be called without actuals because all of
-- their formals (if any) have default values. This flag simplifies the
-- resolution of the syntactic ambiguity involving a call to these
-- entities when the return type is an array type, and a call can be
-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit
-- freeze node, which appears later in the expanded tree.
--- a) The flag is used by the front-end to trigger expansion actions
+-- a) The flag is used by the front-end to trigger expansion actions
-- which include the generation of that freeze node. Typically this happens at
-- the end of the current compilation unit, or before the first subprogram
-- body is encountered in the current unit. See files freeze and exp_ch13 for
-- construction of initialization procedures and dispatch tables.
-- b) The flag is used by the backend to defer elaboration of the entity until
--- its freeze node is seen. In the absence of an explicit freeze node, an
+-- its freeze node is seen. In the absence of an explicit freeze node, an
-- entity is frozen (and elaborated) at the point of declaration.
-- For object declarations, the flag is set when an address clause for the
------------------------------
procedure Expand_N_Case_Expression (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Cstmt : Node_Id;
- Decl : Node_Id;
- Tnn : Entity_Id;
- Pnn : Entity_Id;
- Actions : List_Id;
- Ttyp : Entity_Id;
- Alt : Node_Id;
- Fexp : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Acts : List_Id;
+ Alt : Node_Id;
+ Case_Stmt : Node_Id;
+ Decl : Node_Id;
+ Expr : Node_Id;
+ In_Predicate : Boolean := False;
+ Optimize_Return_Stmt : Boolean := False;
+ Par : Node_Id;
+ Ptr_Typ : Entity_Id;
+ Target : Entity_Id;
+ Target_Typ : Entity_Id;
begin
-- Check for MINIMIZED/ELIMINATED overflow mode
if Ekind_In (Current_Scope, E_Function, E_Procedure)
and then Is_Predicate_Function (Current_Scope)
- and then
- Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
then
- return;
+ In_Predicate := True;
+
+ if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
+ then
+ return;
+ end if;
end if;
-- We expand
-- to
-- do
- -- Tnn : typ;
+ -- Target : typ;
-- case X is
-- when A =>
- -- Tnn := AX;
+ -- Target := AX;
-- when B =>
- -- Tnn := BX;
+ -- Target := BX;
-- ...
-- end case;
- -- in Tnn end;
+ -- in Target end;
+
+ -- Except when the case expression appears as part of a simple return
+ -- statement, returning an elementary type, where we expand
- -- However, this expansion is wrong for limited types, and also
- -- wrong for unconstrained types (since the bounds may not be the
- -- same in all branches). Furthermore it involves an extra copy
- -- for large objects. So we take care of this by using the following
- -- modified expansion for non-elementary types:
+ -- return (case X is when A => AX, when B => BX ...)
+
+ -- to
+
+ -- case X is
+ -- when A =>
+ -- return AX;
+ -- when B =>
+ -- return BX;
+ -- ...
+ -- end case;
+
+ -- Note that this expansion is also triggered for expression functions
+ -- containing a single case expression since these functions are
+ -- expanded as above.
+
+ -- However, this expansion is wrong for limited types, and also wrong
+ -- for unconstrained types (since the bounds may not be the same in all
+ -- branches). Furthermore it involves an extra copy for large objects.
+ -- So we take care of this by using the following modified expansion for
+ -- non-elementary types:
-- do
- -- type Pnn is access all typ;
- -- Tnn : Pnn;
+ -- type Ptr_Typ is access all typ;
+ -- Target : Ptr_Typ;
-- case X is
-- when A =>
- -- T := AX'Unrestricted_Access;
+ -- Target := AX'Unrestricted_Access;
-- when B =>
- -- T := BX'Unrestricted_Access;
+ -- Target := BX'Unrestricted_Access;
-- ...
-- end case;
- -- in Tnn.all end;
+ -- in Target.all end;
- Cstmt :=
+ Case_Stmt :=
Make_Case_Statement (Loc,
Expression => Expression (N),
Alternatives => New_List);
-- the premature finalization of controlled objects found within the
-- case statement.
- Set_From_Conditional_Expression (Cstmt);
-
- Actions := New_List;
+ Set_From_Conditional_Expression (Case_Stmt);
+ Acts := New_List;
-- Scalar case
if Is_Elementary_Type (Typ) then
- Ttyp := Typ;
+ Target_Typ := Typ;
+
+ -- ??? Do not perform the optimization when the return statement is
+ -- within a predicate function as this causes supurious errors. A
+ -- possible mismatch in handling this case somewhere else in semantic
+ -- analysis?
+
+ if not In_Predicate
+ and then Nkind (Parent (N)) = N_Simple_Return_Statement
+ then
+ Optimize_Return_Stmt := True;
+ end if;
else
- Pnn := Make_Temporary (Loc, 'P');
- Append_To (Actions,
+ Ptr_Typ := Make_Temporary (Loc, 'P');
+ Append_To (Acts,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Pnn,
+ Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
- Ttyp := Pnn;
+ Target_Typ := Ptr_Typ;
end if;
- Tnn := Make_Temporary (Loc, 'T');
+ if not Optimize_Return_Stmt then
+ Target := Make_Temporary (Loc, 'T');
- -- Create declaration for target of expression, and indicate that it
- -- does not require initialization.
+ -- Create declaration for target of expression, and indicate that it
+ -- does not require initialization.
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Tnn,
- Object_Definition => New_Occurrence_Of (Ttyp, Loc));
- Set_No_Initialization (Decl);
- Append_To (Actions, Decl);
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Target,
+ Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
+ Set_No_Initialization (Decl);
+ Append_To (Acts, Decl);
+ end if;
-- Now process the alternatives
Alt := First (Alternatives (N));
while Present (Alt) loop
declare
- Aexp : Node_Id := Expression (Alt);
- Aloc : constant Source_Ptr := Sloc (Aexp);
- Stats : List_Id;
+ Alt_Expr : Node_Id := Expression (Alt);
+ Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
+ Stmts : List_Id;
begin
-- As described above, take Unrestricted_Access for case of non-
-- scalar types, to avoid big copies, and special cases.
if not Is_Elementary_Type (Typ) then
- Aexp :=
- Make_Attribute_Reference (Aloc,
- Prefix => Relocate_Node (Aexp),
+ Alt_Expr :=
+ Make_Attribute_Reference (Alt_Loc,
+ Prefix => Relocate_Node (Alt_Expr),
Attribute_Name => Name_Unrestricted_Access);
end if;
- Stats := New_List (
- Make_Assignment_Statement (Aloc,
- Name => New_Occurrence_Of (Tnn, Loc),
- Expression => Aexp));
+ if Optimize_Return_Stmt then
+ Stmts := New_List (
+ Make_Simple_Return_Statement (Alt_Loc,
+ Expression => Alt_Expr));
+ else
+ Stmts := New_List (
+ Make_Assignment_Statement (Alt_Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Expression => Alt_Expr));
+ end if;
-- Propagate declarations inserted in the node by Insert_Actions
-- (for example, temporaries generated to remove side effects).
-- These actions must remain attached to the alternative, given
-- that they are generated by the corresponding expression.
- if Present (Sinfo.Actions (Alt)) then
- Prepend_List (Sinfo.Actions (Alt), Stats);
+ if Present (Actions (Alt)) then
+ Prepend_List (Actions (Alt), Stmts);
end if;
Append_To
- (Alternatives (Cstmt),
+ (Alternatives (Case_Stmt),
Make_Case_Statement_Alternative (Sloc (Alt),
Discrete_Choices => Discrete_Choices (Alt),
- Statements => Stats));
+ Statements => Stmts));
end;
Next (Alt);
end loop;
- Append_To (Actions, Cstmt);
+ -- Rewrite parent return statement as a case statement if possible
+
+ if Optimize_Return_Stmt then
+ Par := Parent (N);
+ Rewrite (Par, Case_Stmt);
+ Analyze (Par);
+ return;
+ end if;
+
+ Append_To (Acts, Case_Stmt);
-- Construct and return final expression with actions
if Is_Elementary_Type (Typ) then
- Fexp := New_Occurrence_Of (Tnn, Loc);
+ Expr := New_Occurrence_Of (Target, Loc);
else
- Fexp :=
+ Expr :=
Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Tnn, Loc));
+ Prefix => New_Occurrence_Of (Target, Loc));
end if;
Rewrite (N,
Make_Expression_With_Actions (Loc,
- Expression => Fexp,
- Actions => Actions));
+ Expression => Expr,
+ Actions => Acts));
Analyze_And_Resolve (N, Typ);
end Expand_N_Case_Expression;
Make_Explicit_Dereference (Loc,
Prefix => Nam);
- if Present (Parameter_Associations (Call_Node)) then
+ if Present (Parameter_Associations (Call_Node)) then
Parm := Parameter_Associations (Call_Node);
else
Parm := New_List;
(RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
return;
- elsif Is_Null_Procedure (Subp) then
+ elsif Is_Null_Procedure (Subp) then
Rewrite (Call_Node, Make_Null_Statement (Loc));
return;
end if;
-- Add friendly warning if initialization comes from a packed array
-- component.
- if Is_Record_Type (Typ) then
+ if Is_Record_Type (Typ) then
declare
Comp : Entity_Id;
-- S p e c --
-- (ASCII Version) --
-- --
--- Copyright (C) 1993-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
function To_Decimal (Item : Binary) return Num;
function To_Decimal (Item : Long_Binary) return Num;
- function To_Binary (Item : Num) return Binary;
- function To_Long_Binary (Item : Num) return Long_Binary;
+ function To_Binary (Item : Num) return Binary;
+ function To_Long_Binary (Item : Num) return Long_Binary;
private
pragma Inline (Length);
function P_Label return Node_Id;
function P_Null_Statement return Node_Id;
- function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
+ function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
-- Parse assignment statement. On entry, the caller has scanned the left
-- hand side (passed in as Lhs), and the colon-equal (or some symbol
-- taken to be an error equivalent such as equal).
for J in reverse 1 .. X'Last loop
RD := RD + DD (X (J));
- if J >= 1 + (X'Last - Y'Last) then
+ if J >= 1 + (X'Last - Y'Last) then
RD := RD + DD (Y (J - (X'Last - Y'Last)));
end if;
for J in reverse 1 .. X'Last loop
RD := RD + DD (X (J));
- if J >= 1 + (X'Last - Y'Last) then
+ if J >= 1 + (X'Last - Y'Last) then
RD := RD - DD (Y (J - (X'Last - Y'Last)));
end if;
Carry := 0;
for J in reverse 1 .. n loop
- Tmp := DD (v (J)) * d + Carry;
- v (J) := LSD (Tmp);
- Carry := Tmp / Base;
+ Tmp := DD (v (J)) * d + Carry;
+ v (J) := LSD (Tmp);
+ Carry := Tmp / Base;
end loop;
pragma Assert (Carry = 0);
OK : constant STATUS := 0;
ERROR : constant STATUS := Interfaces.C.int (-1);
- function taskIdVerify (tid : t_id) return STATUS;
+ function taskIdVerify (tid : t_id) return STATUS;
pragma Import (C, taskIdVerify, "taskIdVerify");
function taskIdSelf return t_id;
G.I := I;
Y := Y xor Shift_Right (Y, U);
- Y := Y xor (Shift_Left (Y, S) and B_Mask);
+ Y := Y xor (Shift_Left (Y, S) and B_Mask);
Y := Y xor (Shift_Left (Y, T) and C_Mask);
Y := Y xor Shift_Right (Y, L);
-- The flag Withed_Body on a context clause indicates that a
-- unit contains an instantiation that may be needed later,
-- and therefore the body that contains the generic body (and
- -- its context) must be traversed immediately after the
+ -- its context) must be traversed immediately after the
-- corresponding spec (see Do_Unit_And_Dependents).
-- The main unit itself is processed separately after all other
else
if Compile_Time_Known_Value (This_Low) then
if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
- Aggr_Low (Dim) := This_Low;
+ Aggr_Low (Dim) := This_Low;
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
Set_Raises_Constraint_Error (N);
if Compile_Time_Known_Value (This_High) then
if not Compile_Time_Known_Value (Aggr_High (Dim)) then
- Aggr_High (Dim) := This_High;
+ Aggr_High (Dim) := This_High;
elsif
Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
Errors_Posted_On_Choices : Boolean := False;
-- Keeps track of whether any choices have semantic errors
- function Empty_Range (A : Node_Id) return Boolean;
+ function Empty_Range (A : Node_Id) return Boolean;
-- If an association covers an empty range, some warnings on the
-- expression of the association can be disabled.
-- Empty_Range --
-----------------
- function Empty_Range (A : Node_Id) return Boolean is
+ function Empty_Range (A : Node_Id) return Boolean is
R : constant Node_Id := First (Choices (A));
begin
return No (Next (R))
end if;
-- All components of the context: with-clauses, library unit, ancestors
- -- if any, (and their context) are analyzed and installed.
+ -- if any, (and their context) are analyzed and installed.
-- Call special debug routine sm if this is the main unit
-- Process_Default --
---------------------
- procedure Process_Default (F : Entity_Id) is
+ procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
Decl : Node_Id;
end loop;
end if;
- if Is_Integer_Type (T) then
+ if Is_Integer_Type (T) then
Resolve (E, T);
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
-- of the derived type are not relevant, and thus we can use
-- the base type for the formals. However, the return type may be
-- used in a context that requires that the proper static bounds
- -- be used (a case statement, for example) and for those cases
+ -- be used (a case statement, for example) and for those cases
-- we must use the derived type (first subtype), not its base.
-- If the derived_type_definition has no constraints, we know that
Set_Referenced_Modified (Lhs, Out_Param => False);
end if;
- -- RM 7.3.2 (12/3) An assignment to a view conversion (from a type
+ -- RM 7.3.2 (12/3): An assignment to a view conversion (from a type
-- to one of its ancestors) requires an invariant check. Apply check
-- only if expression comes from source, otherwise it will be applied
-- when value is assigned to source entity.
then
OK := True;
- -- If the aspect is a predicate (possibly others ???) and the
+ -- If the aspect is a predicate (possibly others ???) and the
-- context is a record type, this is a discriminant expression
-- within a type declaration, that freezes the predicated
-- subtype.
-- Reset the Is_Overloaded flag, since resolution is now completed
+ -- Simple entry call
+
if Nkind (Entry_Name) = N_Selected_Component then
- -- Simple entry call
Set_Is_Overloaded (Selector_Name (Entry_Name), False);
+ -- Call to a member of an entry family
+
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
- -- Call to member of entry family
Set_Is_Overloaded (Selector_Name (Prefix (Entry_Name)), False);
-
end if;
end if;
-- New_Interps --
-----------------
- procedure New_Interps (N : Node_Id) is
+ procedure New_Interps (N : Node_Id) is
Map_Ptr : Int;
begin
end loop;
end if;
- if Present (Prev_Vis) then
+ if Present (Prev_Vis) then
-- Skip E in the visibility chain
else
Indx_Typ := Etype (Indx);
- if Is_Private_Type (Indx_Typ) then
+ if Is_Private_Type (Indx_Typ) then
Indx_Typ := Full_View (Indx_Typ);
end if;
projects / gcc.git / commitdiff