[multiple changes]
2010-10-25 Matthew Heaney <heaney@adacore.com> * Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container) to lists. * a-contai.ads: Added declaration of Capacity_Error exception. * a-cobove.ads, a-cobove.adb: New files. 2010-10-25 Thomas Quinot <quinot@adacore.com> * uname.adb: Revert previous change, no longer needed after change in par-ch10.adb. 2010-10-25 Thomas Quinot <quinot@adacore.com> * scos.ads: Minor comment fix. 2010-10-25 Ed Schonberg <schonberg@adacore.com> * sem_ch5.adb (Analyze_Assignment_Statement): Check dangerous order dependence. * sem_ch6.adb (Analyze_Procedure_Call_Statement): Ditto. * sem_res.adb (Analyze_Actuals): Add actual to list of actuals for current construct, for subsequent order dependence checking. (Resolve): Check order dependence on expressions that are not subexpressions. * sem_util.adb (Check_Order_Dependence): Code cleanup, to correspond to latest version of AI05-144-2. * sem_warn.adb (Warn_On_Overlapping_Actuals): Code cleanup. 2010-10-25 Robert Dewar <dewar@adacore.com> * sem_ch13.adb (Build_Static_Predicate): Moved out of Build_Predicate_Function. (Build_Static_Predicate): Complet rewrite for more general predicates From-SVN: r165917
This commit is contained in:
parent
89ff4f167f
commit
1e194575d0
@ -1,3 +1,38 @@
|
||||
2010-10-25 Matthew Heaney <heaney@adacore.com>
|
||||
|
||||
* Makefile.rtl, impunit.adb: Added a-cobove (bounded vector container)
|
||||
to lists.
|
||||
* a-contai.ads: Added declaration of Capacity_Error exception.
|
||||
* a-cobove.ads, a-cobove.adb: New files.
|
||||
|
||||
2010-10-25 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* uname.adb: Revert previous change, no longer needed after change
|
||||
in par-ch10.adb.
|
||||
|
||||
2010-10-25 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* scos.ads: Minor comment fix.
|
||||
|
||||
2010-10-25 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch5.adb (Analyze_Assignment_Statement): Check dangerous order
|
||||
dependence.
|
||||
* sem_ch6.adb (Analyze_Procedure_Call_Statement): Ditto.
|
||||
* sem_res.adb (Analyze_Actuals): Add actual to list of actuals for
|
||||
current construct, for subsequent order dependence checking.
|
||||
(Resolve): Check order dependence on expressions that are not
|
||||
subexpressions.
|
||||
* sem_util.adb (Check_Order_Dependence): Code cleanup, to correspond
|
||||
to latest version of AI05-144-2.
|
||||
* sem_warn.adb (Warn_On_Overlapping_Actuals): Code cleanup.
|
||||
|
||||
2010-10-25 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_ch13.adb (Build_Static_Predicate): Moved out of
|
||||
Build_Predicate_Function.
|
||||
(Build_Static_Predicate): Complet rewrite for more general predicates
|
||||
|
||||
2010-10-25 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
|
||||
Eric Botcazou <ebotcazou@adacore.com>
|
||||
|
||||
|
@ -114,6 +114,7 @@ GNATRTL_NONTASKING_OBJS= \
|
||||
a-comlin$(objext) \
|
||||
a-contai$(objext) \
|
||||
a-convec$(objext) \
|
||||
a-cobove$(objext) \
|
||||
a-coorma$(objext) \
|
||||
a-coormu$(objext) \
|
||||
a-coorse$(objext) \
|
||||
|
2439
gcc/ada/a-cobove.adb
Normal file
2439
gcc/ada/a-cobove.adb
Normal file
File diff suppressed because it is too large
Load Diff
369
gcc/ada/a-cobove.ads
Normal file
369
gcc/ada/a-cobove.ads
Normal file
@ -0,0 +1,369 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT LIBRARY COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2010, 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 --
|
||||
-- apply solely to the contents of the part following the private keyword. --
|
||||
-- --
|
||||
-- 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- --
|
||||
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
||||
-- --
|
||||
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
||||
-- additional permissions described in the GCC Runtime Library Exception, --
|
||||
-- version 3.1, as published by the Free Software Foundation. --
|
||||
-- --
|
||||
-- You should have received a copy of the GNU General Public License and --
|
||||
-- a copy of the GCC Runtime Library Exception along with this program; --
|
||||
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
||||
-- <http://www.gnu.org/licenses/>. --
|
||||
-- --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
private with Ada.Streams;
|
||||
|
||||
generic
|
||||
type Index_Type is range <>;
|
||||
type Element_Type is private;
|
||||
|
||||
with function "=" (Left, Right : Element_Type) return Boolean is <>;
|
||||
|
||||
package Ada.Containers.Bounded_Vectors is
|
||||
pragma Pure;
|
||||
pragma Remote_Types;
|
||||
|
||||
subtype Extended_Index is Index_Type'Base
|
||||
range Index_Type'First - 1 ..
|
||||
Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
|
||||
|
||||
No_Index : constant Extended_Index := Extended_Index'First;
|
||||
|
||||
type Vector (Capacity : Count_Type) is tagged private;
|
||||
pragma Preelaborable_Initialization (Vector);
|
||||
|
||||
type Cursor is private;
|
||||
pragma Preelaborable_Initialization (Cursor);
|
||||
|
||||
Empty_Vector : constant Vector;
|
||||
|
||||
No_Element : constant Cursor;
|
||||
|
||||
overriding function "=" (Left, Right : Vector) return Boolean;
|
||||
|
||||
function To_Vector (Length : Count_Type) return Vector;
|
||||
|
||||
function To_Vector
|
||||
(New_Item : Element_Type;
|
||||
Length : Count_Type) return Vector;
|
||||
|
||||
function "&" (Left, Right : Vector) return Vector;
|
||||
|
||||
function "&" (Left : Vector; Right : Element_Type) return Vector;
|
||||
|
||||
function "&" (Left : Element_Type; Right : Vector) return Vector;
|
||||
|
||||
function "&" (Left, Right : Element_Type) return Vector;
|
||||
|
||||
function Capacity (Container : Vector) return Count_Type;
|
||||
|
||||
procedure Reserve_Capacity
|
||||
(Container : in out Vector;
|
||||
Capacity : Count_Type);
|
||||
|
||||
function Length (Container : Vector) return Count_Type;
|
||||
|
||||
procedure Set_Length
|
||||
(Container : in out Vector;
|
||||
Length : Count_Type);
|
||||
|
||||
function Is_Empty (Container : Vector) return Boolean;
|
||||
|
||||
procedure Clear (Container : in out Vector);
|
||||
|
||||
function To_Cursor
|
||||
(Container : Vector;
|
||||
Index : Extended_Index) return Cursor;
|
||||
|
||||
function To_Index (Position : Cursor) return Extended_Index;
|
||||
|
||||
function Element
|
||||
(Container : Vector;
|
||||
Index : Index_Type) return Element_Type;
|
||||
|
||||
function Element (Position : Cursor) return Element_Type;
|
||||
|
||||
procedure Replace_Element
|
||||
(Container : in out Vector;
|
||||
Index : Index_Type;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Replace_Element
|
||||
(Container : in out Vector;
|
||||
Position : Cursor;
|
||||
New_Item : Element_Type);
|
||||
|
||||
procedure Query_Element
|
||||
(Container : Vector;
|
||||
Index : Index_Type;
|
||||
Process : not null access procedure (Element : Element_Type));
|
||||
|
||||
procedure Query_Element
|
||||
(Position : Cursor;
|
||||
Process : not null access procedure (Element : Element_Type));
|
||||
|
||||
procedure Update_Element
|
||||
(Container : in out Vector;
|
||||
Index : Index_Type;
|
||||
Process : not null access procedure (Element : in out Element_Type));
|
||||
|
||||
procedure Update_Element
|
||||
(Container : in out Vector;
|
||||
Position : Cursor;
|
||||
Process : not null access procedure (Element : in out Element_Type));
|
||||
|
||||
procedure Assign (Target : in out Vector; Source : Vector);
|
||||
|
||||
function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector;
|
||||
|
||||
procedure Move (Target : in out Vector; Source : in out Vector);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Extended_Index;
|
||||
New_Item : Vector);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
New_Item : Vector);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
New_Item : Vector;
|
||||
Position : out Cursor);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Extended_Index;
|
||||
New_Item : Element_Type;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
New_Item : Element_Type;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
New_Item : Element_Type;
|
||||
Position : out Cursor;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Extended_Index;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
Position : out Cursor;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Prepend
|
||||
(Container : in out Vector;
|
||||
New_Item : Vector);
|
||||
|
||||
procedure Prepend
|
||||
(Container : in out Vector;
|
||||
New_Item : Element_Type;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Append
|
||||
(Container : in out Vector;
|
||||
New_Item : Vector);
|
||||
|
||||
procedure Append
|
||||
(Container : in out Vector;
|
||||
New_Item : Element_Type;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert_Space
|
||||
(Container : in out Vector;
|
||||
Before : Extended_Index;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Insert_Space
|
||||
(Container : in out Vector;
|
||||
Before : Cursor;
|
||||
Position : out Cursor;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Delete
|
||||
(Container : in out Vector;
|
||||
Index : Extended_Index;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Delete
|
||||
(Container : in out Vector;
|
||||
Position : in out Cursor;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Delete_First
|
||||
(Container : in out Vector;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Delete_Last
|
||||
(Container : in out Vector;
|
||||
Count : Count_Type := 1);
|
||||
|
||||
procedure Reverse_Elements (Container : in out Vector);
|
||||
|
||||
procedure Swap (Container : in out Vector; I, J : Index_Type);
|
||||
|
||||
procedure Swap (Container : in out Vector; I, J : Cursor);
|
||||
|
||||
function First_Index (Container : Vector) return Index_Type;
|
||||
|
||||
function First (Container : Vector) return Cursor;
|
||||
|
||||
function First_Element (Container : Vector) return Element_Type;
|
||||
|
||||
function Last_Index (Container : Vector) return Extended_Index;
|
||||
|
||||
function Last (Container : Vector) return Cursor;
|
||||
|
||||
function Last_Element (Container : Vector) return Element_Type;
|
||||
|
||||
function Next (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Next (Position : in out Cursor);
|
||||
|
||||
function Previous (Position : Cursor) return Cursor;
|
||||
|
||||
procedure Previous (Position : in out Cursor);
|
||||
|
||||
function Find_Index
|
||||
(Container : Vector;
|
||||
Item : Element_Type;
|
||||
Index : Index_Type := Index_Type'First) return Extended_Index;
|
||||
|
||||
function Find
|
||||
(Container : Vector;
|
||||
Item : Element_Type;
|
||||
Position : Cursor := No_Element) return Cursor;
|
||||
|
||||
function Reverse_Find_Index
|
||||
(Container : Vector;
|
||||
Item : Element_Type;
|
||||
Index : Index_Type := Index_Type'Last) return Extended_Index;
|
||||
|
||||
function Reverse_Find
|
||||
(Container : Vector;
|
||||
Item : Element_Type;
|
||||
Position : Cursor := No_Element) return Cursor;
|
||||
|
||||
function Contains
|
||||
(Container : Vector;
|
||||
Item : Element_Type) return Boolean;
|
||||
|
||||
function Has_Element (Position : Cursor) return Boolean;
|
||||
|
||||
procedure Iterate
|
||||
(Container : Vector;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
procedure Reverse_Iterate
|
||||
(Container : Vector;
|
||||
Process : not null access procedure (Position : Cursor));
|
||||
|
||||
generic
|
||||
with function "<" (Left, Right : Element_Type) return Boolean is <>;
|
||||
package Generic_Sorting is
|
||||
|
||||
function Is_Sorted (Container : Vector) return Boolean;
|
||||
|
||||
procedure Sort (Container : in out Vector);
|
||||
|
||||
procedure Merge (Target : in out Vector; Source : in out Vector);
|
||||
|
||||
end Generic_Sorting;
|
||||
|
||||
private
|
||||
|
||||
pragma Inline (First_Index);
|
||||
pragma Inline (Last_Index);
|
||||
pragma Inline (Element);
|
||||
pragma Inline (First_Element);
|
||||
pragma Inline (Last_Element);
|
||||
pragma Inline (Query_Element);
|
||||
pragma Inline (Update_Element);
|
||||
pragma Inline (Replace_Element);
|
||||
pragma Inline (Is_Empty);
|
||||
pragma Inline (Contains);
|
||||
pragma Inline (Next);
|
||||
pragma Inline (Previous);
|
||||
|
||||
type Elements_Array is array (Count_Type range <>) of Element_Type;
|
||||
function "=" (L, R : Elements_Array) return Boolean is abstract;
|
||||
|
||||
type Vector (Capacity : Count_Type) is tagged record
|
||||
Elements : Elements_Array (1 .. Capacity);
|
||||
Last : Extended_Index := No_Index;
|
||||
Busy : Natural := 0;
|
||||
Lock : Natural := 0;
|
||||
end record;
|
||||
|
||||
use Ada.Streams;
|
||||
|
||||
procedure Write
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Container : Vector);
|
||||
|
||||
for Vector'Write use Write;
|
||||
|
||||
procedure Read
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Container : out Vector);
|
||||
|
||||
for Vector'Read use Read;
|
||||
|
||||
type Vector_Access is access all Vector;
|
||||
for Vector_Access'Storage_Size use 0;
|
||||
|
||||
type Cursor is record
|
||||
Container : Vector_Access;
|
||||
Index : Index_Type := Index_Type'First;
|
||||
end record;
|
||||
|
||||
procedure Write
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Position : Cursor);
|
||||
|
||||
for Cursor'Write use Write;
|
||||
|
||||
procedure Read
|
||||
(Stream : not null access Root_Stream_Type'Class;
|
||||
Position : out Cursor);
|
||||
|
||||
for Cursor'Read use Read;
|
||||
|
||||
Empty_Vector : constant Vector := (Capacity => 0, others => <>);
|
||||
|
||||
No_Element : constant Cursor := Cursor'(null, Index_Type'First);
|
||||
|
||||
end Ada.Containers.Bounded_Vectors;
|
@ -19,4 +19,6 @@ package Ada.Containers is
|
||||
type Hash_Type is mod 2**32;
|
||||
type Count_Type is range 0 .. 2**31 - 1;
|
||||
|
||||
Capacity_Error : exception;
|
||||
|
||||
end Ada.Containers;
|
||||
|
@ -506,7 +506,8 @@ package body Impunit is
|
||||
|
||||
Non_Imp_File_Names_12 : constant File_List := (
|
||||
"s-multip", -- System.Multiprocessors
|
||||
"s-mudido"); -- System.Multiprocessors.Dispatching_Domains
|
||||
"s-mudido", -- System.Multiprocessors.Dispatching_Domains
|
||||
"a-cobove"); -- Ada.Containers.Bounded_Vectors
|
||||
|
||||
-----------------------
|
||||
-- Alternative Units --
|
||||
|
@ -240,7 +240,7 @@ package SCOs is
|
||||
-- expression ::= |sloc term term (if expr is OR or OR ELSE)
|
||||
-- expression ::= !sloc term (if expr is NOT)
|
||||
|
||||
-- In the last four cases, sloc is the source location of the AND, OR,
|
||||
-- In the last three cases, sloc is the source location of the AND, OR,
|
||||
-- or NOT token, respectively.
|
||||
|
||||
-- term ::= element
|
||||
|
1179
gcc/ada/sem_ch13.adb
1179
gcc/ada/sem_ch13.adb
File diff suppressed because it is too large
Load Diff
@ -662,6 +662,7 @@ package body Sem_Ch5 is
|
||||
-- checks have been applied.
|
||||
|
||||
Note_Possible_Modification (Lhs, Sure => True);
|
||||
Check_Order_Dependence;
|
||||
|
||||
-- ??? a real accessibility check is needed when ???
|
||||
|
||||
|
@ -811,9 +811,8 @@ package body Sem_Ch6 is
|
||||
end if;
|
||||
|
||||
-- Apply checks suggested by AI05-0144 (dangerous order dependence)
|
||||
-- (Disabled for now)
|
||||
|
||||
-- Check_Order_Dependence;
|
||||
Check_Order_Dependence;
|
||||
end if;
|
||||
end Analyze_Function_Return;
|
||||
|
||||
@ -1116,9 +1115,9 @@ package body Sem_Ch6 is
|
||||
Analyze_Call (N);
|
||||
Resolve (N, Standard_Void_Type);
|
||||
|
||||
-- Apply checks suggested by AI05-0144 (Disabled for now)
|
||||
-- Apply checks suggested by AI05-0144
|
||||
|
||||
-- Check_Order_Dependence;
|
||||
Check_Order_Dependence;
|
||||
|
||||
else
|
||||
Analyze (N);
|
||||
|
@ -2744,6 +2744,18 @@ package body Sem_Res is
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- AI05-144-2: Check dangerous order dependence within an expression
|
||||
-- that is not a subexpression. Exclude RHS of an assignment, because
|
||||
-- both sides may have side-effects and the check must be performed
|
||||
-- over the statement.
|
||||
|
||||
if Nkind (Parent (N)) not in N_Subexpr
|
||||
and then Nkind (Parent (N)) /= N_Assignment_Statement
|
||||
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
|
||||
then
|
||||
Check_Order_Dependence;
|
||||
end if;
|
||||
|
||||
-- The expression is definitely NOT overloaded at this point, so
|
||||
-- we reset the Is_Overloaded flag to avoid any confusion when
|
||||
-- reanalyzing the node.
|
||||
@ -3529,12 +3541,10 @@ package body Sem_Res is
|
||||
A_Typ := Etype (A);
|
||||
F_Typ := Etype (F);
|
||||
|
||||
-- Save actual for subsequent check on order dependence,
|
||||
-- and indicate whether actual is modifiable. For AI05-0144
|
||||
-- Save actual for subsequent check on order dependence, and
|
||||
-- indicate whether actual is modifiable. For AI05-0144-2.
|
||||
|
||||
-- Save_Actual (A,
|
||||
-- Ekind (F) /= E_In_Parameter or else Is_Access_Type (F_Typ));
|
||||
-- Why is this code commented out ???
|
||||
Save_Actual (A, Ekind (F) /= E_In_Parameter);
|
||||
|
||||
-- For mode IN, if actual is an entity, and the type of the formal
|
||||
-- has warnings suppressed, then we reset Never_Set_In_Source for
|
||||
@ -8228,11 +8238,8 @@ package body Sem_Res is
|
||||
R : constant Node_Id := Right_Opnd (N);
|
||||
|
||||
begin
|
||||
-- Why are the calls to Check_Order_Dependence commented out ???
|
||||
Resolve (L, B_Typ);
|
||||
-- Check_Order_Dependence; -- For AI05-0144
|
||||
Resolve (R, B_Typ);
|
||||
-- Check_Order_Dependence; -- For AI05-0144
|
||||
|
||||
-- Check for issuing warning for always False assert/check, this happens
|
||||
-- when assertions are turned off, in which case the pragma Assert/Check
|
||||
|
@ -101,12 +101,12 @@ package body Sem_Util is
|
||||
-- whether the corresponding formal is OUT or IN OUT. Each top-level call
|
||||
-- (procedure call, condition, assignment) examines all the actuals for a
|
||||
-- possible order dependence. The table is reset after each such check.
|
||||
-- The actuals to be checked in a call to Check_Order_Dependence are at
|
||||
-- positions 1 .. Last.
|
||||
|
||||
type Actual_Name is record
|
||||
Act : Node_Id;
|
||||
Is_Writable : Boolean;
|
||||
-- Comments needed???
|
||||
|
||||
end record;
|
||||
|
||||
package Actuals_In_Call is new Table.Table (
|
||||
@ -1222,9 +1222,17 @@ package body Sem_Util is
|
||||
Act2 : Node_Id;
|
||||
|
||||
begin
|
||||
-- This could use comments ???
|
||||
if Ada_Version < Ada_2012 then
|
||||
return;
|
||||
end if;
|
||||
|
||||
for J in 0 .. Actuals_In_Call.Last loop
|
||||
-- Ada2012 AI04-0144-2 : dangerous order dependence.
|
||||
-- Actuals in nested calls within a construct have been collected.
|
||||
-- If one of them is writeable and overlaps with another one, evaluation
|
||||
-- of the enclosing construct is non-deterministic.
|
||||
-- This is illegal in Ada2012, but is treated as a warning for now.
|
||||
|
||||
for J in 1 .. Actuals_In_Call.Last loop
|
||||
if Actuals_In_Call.Table (J).Is_Writable then
|
||||
Act1 := Actuals_In_Call.Table (J).Act;
|
||||
|
||||
@ -1232,7 +1240,7 @@ package body Sem_Util is
|
||||
Act1 := Prefix (Act1);
|
||||
end if;
|
||||
|
||||
for K in 0 .. Actuals_In_Call.Last loop
|
||||
for K in 1 .. Actuals_In_Call.Last loop
|
||||
if K /= J then
|
||||
Act2 := Actuals_In_Call.Table (K).Act;
|
||||
|
||||
@ -1248,15 +1256,19 @@ package body Sem_Util is
|
||||
null;
|
||||
|
||||
elsif Denotes_Same_Object (Act1, Act2)
|
||||
and then False
|
||||
and then Parent (Act1) /= Parent (Act2)
|
||||
then
|
||||
Error_Msg_N ("?,mighty suspicious!!!", Act1);
|
||||
Error_Msg_N (
|
||||
"result may differ if evaluated "
|
||||
& " after other actual in expression?", Act1);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
-- Remove checked actuals from table.
|
||||
|
||||
Actuals_In_Call.Set_Last (0);
|
||||
end Check_Order_Dependence;
|
||||
|
||||
@ -2350,49 +2362,105 @@ package body Sem_Util is
|
||||
-------------------------
|
||||
|
||||
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean is
|
||||
Obj1 : Node_Id := A1;
|
||||
Obj2 : Node_Id := A2;
|
||||
|
||||
procedure Check_Renaming (Obj : in out Node_Id);
|
||||
-- If an object is a renaming, examine renamed object. If is is a
|
||||
-- dereference of a variable, or an indexed expression with non-
|
||||
-- constant indices, no overlap check can be reported.
|
||||
|
||||
procedure Check_Renaming (Obj : in out Node_Id) is
|
||||
begin
|
||||
if Is_Entity_Name (Obj)
|
||||
and then Present (Renamed_Entity (Entity (Obj)))
|
||||
then
|
||||
Obj := Renamed_Entity (Entity (Obj));
|
||||
if Nkind (Obj) = N_Explicit_Dereference
|
||||
and then Is_Variable (Prefix (Obj))
|
||||
then
|
||||
Obj := Empty;
|
||||
|
||||
elsif Nkind (Obj) = N_Indexed_Component then
|
||||
declare
|
||||
Indx : Node_Id;
|
||||
|
||||
begin
|
||||
Indx := First (Expressions (Obj));
|
||||
while Present (Indx) loop
|
||||
if not Is_OK_Static_Expression (Indx) then
|
||||
Obj := Empty;
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Index (Indx);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
end Check_Renaming;
|
||||
|
||||
begin
|
||||
Check_Renaming (Obj1);
|
||||
Check_Renaming (Obj2);
|
||||
|
||||
if No (Obj1)
|
||||
or else No (Obj2)
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- If we have entity names, then must be same entity
|
||||
|
||||
if Is_Entity_Name (A1) then
|
||||
if Is_Entity_Name (A2) then
|
||||
return Entity (A1) = Entity (A2);
|
||||
if Is_Entity_Name (Obj1) then
|
||||
if Is_Entity_Name (Obj2) then
|
||||
return Entity (Obj1) = Entity (Obj2);
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- No match if not same node kind
|
||||
|
||||
elsif Nkind (A1) /= Nkind (A2) then
|
||||
elsif Nkind (Obj1) /= Nkind (Obj2) then
|
||||
return False;
|
||||
|
||||
-- For selected components, must have same prefix and selector
|
||||
|
||||
elsif Nkind (A1) = N_Selected_Component then
|
||||
return Denotes_Same_Object (Prefix (A1), Prefix (A2))
|
||||
elsif Nkind (Obj1) = N_Selected_Component then
|
||||
return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
|
||||
and then
|
||||
Entity (Selector_Name (A1)) = Entity (Selector_Name (A2));
|
||||
Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
|
||||
|
||||
-- For explicit dereferences, prefixes must be same
|
||||
|
||||
elsif Nkind (A1) = N_Explicit_Dereference then
|
||||
return Denotes_Same_Object (Prefix (A1), Prefix (A2));
|
||||
elsif Nkind (Obj1) = N_Explicit_Dereference then
|
||||
return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
|
||||
|
||||
-- For indexed components, prefixes and all subscripts must be the same
|
||||
|
||||
elsif Nkind (A1) = N_Indexed_Component then
|
||||
if Denotes_Same_Object (Prefix (A1), Prefix (A2)) then
|
||||
elsif Nkind (Obj1) = N_Indexed_Component then
|
||||
if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
|
||||
declare
|
||||
Indx1 : Node_Id;
|
||||
Indx2 : Node_Id;
|
||||
|
||||
begin
|
||||
Indx1 := First (Expressions (A1));
|
||||
Indx2 := First (Expressions (A2));
|
||||
Indx1 := First (Expressions (Obj1));
|
||||
Indx2 := First (Expressions (Obj2));
|
||||
while Present (Indx1) loop
|
||||
|
||||
-- Shouldn't we be checking that values are the same???
|
||||
-- Indices must denote the same static value or the same
|
||||
-- object.
|
||||
|
||||
if not Denotes_Same_Object (Indx1, Indx2) then
|
||||
if Is_OK_Static_Expression (Indx1) then
|
||||
if not Is_OK_Static_Expression (Indx2) then
|
||||
return False;
|
||||
|
||||
elsif Expr_Value (Indx1) /= Expr_Value (Indx2) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
elsif not Denotes_Same_Object (Indx1, Indx2) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
@ -2408,21 +2476,19 @@ package body Sem_Util is
|
||||
|
||||
-- For slices, prefixes must match and bounds must match
|
||||
|
||||
elsif Nkind (A1) = N_Slice
|
||||
and then Denotes_Same_Object (Prefix (A1), Prefix (A2))
|
||||
elsif Nkind (Obj1) = N_Slice
|
||||
and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
|
||||
then
|
||||
declare
|
||||
Lo1, Lo2, Hi1, Hi2 : Node_Id;
|
||||
|
||||
begin
|
||||
Get_Index_Bounds (Etype (A1), Lo1, Hi1);
|
||||
Get_Index_Bounds (Etype (A2), Lo2, Hi2);
|
||||
Get_Index_Bounds (Etype (Obj1), Lo1, Hi1);
|
||||
Get_Index_Bounds (Etype (Obj2), Lo2, Hi2);
|
||||
|
||||
-- Check whether bounds are statically identical. There is no
|
||||
-- attempt to detect partial overlap of slices.
|
||||
|
||||
-- What about an array and a slice of an array???
|
||||
|
||||
return Denotes_Same_Object (Lo1, Lo2)
|
||||
and then Denotes_Same_Object (Hi1, Hi2);
|
||||
end;
|
||||
@ -2430,8 +2496,8 @@ package body Sem_Util is
|
||||
-- Literals will appear as indexes. Isn't this where we should check
|
||||
-- Known_At_Compile_Time at least if we are generating warnings ???
|
||||
|
||||
elsif Nkind (A1) = N_Integer_Literal then
|
||||
return Intval (A1) = Intval (A2);
|
||||
elsif Nkind (Obj1) = N_Integer_Literal then
|
||||
return Intval (Obj1) = Intval (Obj2);
|
||||
|
||||
else
|
||||
return False;
|
||||
@ -10696,7 +10762,10 @@ package body Sem_Util is
|
||||
|
||||
procedure Save_Actual (N : Node_Id; Writable : Boolean := False) is
|
||||
begin
|
||||
if Is_Entity_Name (N)
|
||||
if Ada_Version < Ada_2012 then
|
||||
return;
|
||||
|
||||
elsif Is_Entity_Name (N)
|
||||
or else
|
||||
Nkind_In (N, N_Indexed_Component, N_Selected_Component, N_Slice)
|
||||
or else
|
||||
|
@ -3708,7 +3708,7 @@ package body Sem_Warn is
|
||||
Form1 := First_Formal (Subp);
|
||||
Act1 := First_Actual (N);
|
||||
while Present (Form1) and then Present (Act1) loop
|
||||
if Ekind (Form1) = E_In_Out_Parameter then
|
||||
if Ekind (Form1) /= E_In_Parameter then
|
||||
Form2 := First_Formal (Subp);
|
||||
Act2 := First_Actual (N);
|
||||
while Present (Form2) and then Present (Act2) loop
|
||||
@ -3739,11 +3739,11 @@ package body Sem_Warn is
|
||||
elsif Nkind (Act2) = N_Function_Call then
|
||||
null;
|
||||
|
||||
-- If either type is elementary the aliasing is harmless.
|
||||
-- If type is not by-copy we can assume that the aliasing
|
||||
-- is intended.
|
||||
|
||||
elsif Is_Elementary_Type (Underlying_Type (Etype (Form1)))
|
||||
or else
|
||||
Is_Elementary_Type (Underlying_Type (Etype (Form2)))
|
||||
elsif
|
||||
Is_By_Reference_Type (Underlying_Type (Etype (Form1)))
|
||||
then
|
||||
null;
|
||||
|
||||
@ -3762,11 +3762,21 @@ package body Sem_Warn is
|
||||
Next_Actual (Act);
|
||||
end loop;
|
||||
|
||||
if Is_Elementary_Type (Etype (Act1))
|
||||
and then Ekind (Form2) = E_In_Parameter
|
||||
then
|
||||
null; -- no real aliasing.
|
||||
|
||||
elsif Is_Elementary_Type (Etype (Act2))
|
||||
and then Ekind (Form2) = E_In_Parameter
|
||||
then
|
||||
null; -- ditto
|
||||
|
||||
-- If the call was written in prefix notation, and
|
||||
-- thus its prefix before rewriting was a selected
|
||||
-- component, count only visible actuals in the call.
|
||||
|
||||
if Is_Entity_Name (First_Actual (N))
|
||||
elsif Is_Entity_Name (First_Actual (N))
|
||||
and then Nkind (Original_Node (N)) = Nkind (N)
|
||||
and then Nkind (Name (Original_Node (N))) =
|
||||
N_Selected_Component
|
||||
|
@ -225,10 +225,10 @@ package body Uname is
|
||||
Kind : constant Node_Kind := Nkind (Node);
|
||||
|
||||
begin
|
||||
-- Bail out on error node (guard against parse error)
|
||||
-- Just ignore an error node (someone else will give a message)
|
||||
|
||||
if Node = Error then
|
||||
raise Program_Error;
|
||||
return;
|
||||
|
||||
-- Otherwise see what kind of node we have
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user