[multiple changes]
2011-08-02 Robert Dewar <dewar@adacore.com> * a-direct.adb, sinfo.ads, exp_ch9.adb, scng.adb, sem_util.adb, sem_util.ads, restrict.ads, par-prag.adb: Minor reformatting and/or code reorganization. 2011-08-02 Robert Dewar <dewar@adacore.com> * debug.adb: Debug flag d.P to suppress length comparison optimization * exp_ch4.adb (Optimize_Length_Comparison): New routine to optimize comparison of Length by comparing First/Last instead. 2011-08-02 Matthew Heaney <heaney@adacore.com> * a-cobove.ads: Code clean up. From-SVN: r177190
This commit is contained in:
Arnaud Charlet
parent
b191a12525
commit
0580d80707
|
|
@ -1,3 +1,19 @@
|
|||
2011-08-02 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* a-direct.adb, sinfo.ads, exp_ch9.adb, scng.adb, sem_util.adb,
|
||||
sem_util.ads, restrict.ads, par-prag.adb: Minor reformatting and/or
|
||||
code reorganization.
|
||||
|
||||
2011-08-02 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* debug.adb: Debug flag d.P to suppress length comparison optimization
|
||||
* exp_ch4.adb (Optimize_Length_Comparison): New routine to optimize
|
||||
comparison of Length by comparing First/Last instead.
|
||||
|
||||
2011-08-02 Matthew Heaney <heaney@adacore.com>
|
||||
|
||||
* a-cobove.ads: Code clean up.
|
||||
|
||||
2011-08-02 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* adaint.c (file_names_case_sensitive_cache): New static int.
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2004-2011, 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 --
|
||||
|
|
@ -322,7 +322,7 @@ private
|
|||
function "=" (L, R : Elements_Array) return Boolean is abstract;
|
||||
|
||||
type Vector (Capacity : Count_Type) is tagged record
|
||||
Elements : Elements_Array (1 .. Capacity);
|
||||
Elements : Elements_Array (1 .. Capacity) := (others => <>);
|
||||
Last : Extended_Index := No_Index;
|
||||
Busy : Natural := 0;
|
||||
Lock : Natural := 0;
|
||||
|
|
|
|||
|
|
@ -39,23 +39,23 @@ with Ada.Unchecked_Conversion;
|
|||
with Ada.Unchecked_Deallocation;
|
||||
with Ada.Characters.Handling; use Ada.Characters.Handling;
|
||||
|
||||
with System.CRTL; use System.CRTL;
|
||||
with System.OS_Constants;
|
||||
with System.OS_Lib; use System.OS_Lib;
|
||||
with System.Regexp; use System.Regexp;
|
||||
with System.File_IO; use System.File_IO;
|
||||
with System;
|
||||
with System.CRTL; use System.CRTL;
|
||||
with System.OS_Constants; use System.OS_Constants;
|
||||
with System.OS_Lib; use System.OS_Lib;
|
||||
with System.Regexp; use System.Regexp;
|
||||
with System.File_IO; use System.File_IO;
|
||||
with System; use System;
|
||||
|
||||
package body Ada.Directories is
|
||||
|
||||
Filename_Max : constant Integer := 1024;
|
||||
-- 1024 is the value of FILENAME_MAX in stdio.h
|
||||
|
||||
type Dir_Type_Value is new System.Address;
|
||||
type Dir_Type_Value is new Address;
|
||||
-- This is the low-level address directory structure as returned by the C
|
||||
-- opendir routine.
|
||||
|
||||
No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);
|
||||
No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address);
|
||||
|
||||
Dir_Separator : constant Character;
|
||||
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
|
||||
|
|
@ -384,7 +384,7 @@ package body Ada.Directories is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- The implementation uses System.OS_Lib.Copy_File
|
||||
-- Do actual copy using System.OS_Lib.Copy_File
|
||||
|
||||
Copy_File (Source_Name, Target_Name, Success, Mode, Preserve);
|
||||
|
||||
|
|
@ -496,9 +496,7 @@ package body Ada.Directories is
|
|||
Path_Len : Natural := Max_Path;
|
||||
Buffer : String (1 .. 1 + Max_Path + 1);
|
||||
|
||||
procedure Local_Get_Current_Dir
|
||||
(Dir : System.Address;
|
||||
Length : System.Address);
|
||||
procedure Local_Get_Current_Dir (Dir : Address; Length : Address);
|
||||
pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
|
||||
|
||||
begin
|
||||
|
|
@ -563,7 +561,7 @@ package body Ada.Directories is
|
|||
raise Name_Error with "file """ & Name & """ does not exist";
|
||||
|
||||
else
|
||||
-- The implementation uses System.OS_Lib.Delete_File
|
||||
-- Do actual deletion using System.OS_Lib.Delete_File
|
||||
|
||||
Delete_File (Name, Success);
|
||||
|
||||
|
|
@ -602,7 +600,7 @@ package body Ada.Directories is
|
|||
File_Name : constant String := Simple_Name (Dir_Ent);
|
||||
|
||||
begin
|
||||
if System.OS_Lib.Is_Directory (File_Name) then
|
||||
if OS_Lib.Is_Directory (File_Name) then
|
||||
if File_Name /= "." and then File_Name /= ".." then
|
||||
Delete_Tree (File_Name);
|
||||
end if;
|
||||
|
|
@ -698,7 +696,7 @@ package body Ada.Directories is
|
|||
Kind : File_Kind := Ordinary_File;
|
||||
-- Initialized to avoid a compilation warning
|
||||
|
||||
Filename_Addr : System.Address;
|
||||
Filename_Addr : Address;
|
||||
Filename_Len : aliased Integer;
|
||||
|
||||
Buffer : array (0 .. Filename_Max + 12) of Character;
|
||||
|
|
@ -706,26 +704,24 @@ package body Ada.Directories is
|
|||
-- field for the filename.
|
||||
|
||||
function readdir_gnat
|
||||
(Directory : System.Address;
|
||||
Buffer : System.Address;
|
||||
Last : not null access Integer) return System.Address;
|
||||
(Directory : Address;
|
||||
Buffer : Address;
|
||||
Last : not null access Integer) return Address;
|
||||
pragma Import (C, readdir_gnat, "__gnat_readdir");
|
||||
|
||||
use System;
|
||||
|
||||
begin
|
||||
-- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
|
||||
|
||||
loop
|
||||
Filename_Addr :=
|
||||
readdir_gnat
|
||||
(System.Address (Search.Value.Dir),
|
||||
(Address (Search.Value.Dir),
|
||||
Buffer'Address,
|
||||
Filename_Len'Access);
|
||||
|
||||
-- If no matching entry is found, set Is_Valid to False
|
||||
|
||||
if Filename_Addr = System.Null_Address then
|
||||
if Filename_Addr = Null_Address then
|
||||
Search.Value.Is_Valid := False;
|
||||
exit;
|
||||
end if;
|
||||
|
|
@ -801,7 +797,7 @@ package body Ada.Directories is
|
|||
-----------------
|
||||
|
||||
function File_Exists (Name : String) return Boolean is
|
||||
function C_File_Exists (A : System.Address) return Integer;
|
||||
function C_File_Exists (A : Address) return Integer;
|
||||
pragma Import (C, C_File_Exists, "__gnat_file_exists");
|
||||
|
||||
C_Name : String (1 .. Name'Length + 1);
|
||||
|
|
@ -848,9 +844,11 @@ package body Ada.Directories is
|
|||
|
||||
declare
|
||||
-- We need to resolve links because of A.16(47), since we must not
|
||||
-- return alternative names for files
|
||||
-- return alternative names for files.
|
||||
|
||||
Value : constant String := Normalize_Pathname (Name);
|
||||
subtype Result is String (1 .. Value'Length);
|
||||
|
||||
begin
|
||||
return Result (Value);
|
||||
end;
|
||||
|
|
@ -1056,18 +1054,19 @@ package body Ada.Directories is
|
|||
& """ designates a file that already exists";
|
||||
|
||||
else
|
||||
-- The implementation uses System.OS_Lib.Rename_File
|
||||
-- Do actual rename using System.OS_Lib.Rename_File
|
||||
|
||||
Rename_File (Old_Name, New_Name, Success);
|
||||
|
||||
if not Success then
|
||||
|
||||
-- AI05-0231-1: Name_Error should be raised in case a directory
|
||||
-- component of New_Name does not exist (as in New_Name =>
|
||||
-- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT
|
||||
-- also indicate that the Old_Name does not exist, but we already
|
||||
-- checked for that above. All other errors are Use_Error.
|
||||
|
||||
if Errno = System.OS_Constants.ENOENT then
|
||||
if Errno = ENOENT then
|
||||
raise Name_Error with
|
||||
"file """ & Containing_Directory (New_Name) & """ not found";
|
||||
|
||||
|
|
@ -1154,9 +1153,10 @@ package body Ada.Directories is
|
|||
Cut_End := Path'Last;
|
||||
|
||||
Check_For_Standard_Dirs : declare
|
||||
BN : constant String := Path (Cut_Start .. Cut_End);
|
||||
BN : constant String := Path (Cut_Start .. Cut_End);
|
||||
|
||||
Has_Drive_Letter : constant Boolean :=
|
||||
System.OS_Lib.Path_Separator /= ':';
|
||||
OS_Lib.Path_Separator /= ':';
|
||||
-- If Path separator is not ':' then we are on a DOS based OS
|
||||
-- where this character is used as a drive letter separator.
|
||||
|
||||
|
|
@ -1221,7 +1221,7 @@ package body Ada.Directories is
|
|||
function Size (Name : String) return File_Size is
|
||||
C_Name : String (1 .. Name'Length + 1);
|
||||
|
||||
function C_Size (Name : System.Address) return Long_Integer;
|
||||
function C_Size (Name : Address) return Long_Integer;
|
||||
pragma Import (C, C_Size, "__gnat_named_file_length");
|
||||
|
||||
begin
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ package body Debug is
|
|||
-- d.M
|
||||
-- d.N
|
||||
-- d.O Dump internal SCO tables
|
||||
-- d.P
|
||||
-- d.P Previous (non-optimized) handling of length comparisons
|
||||
-- d.Q
|
||||
-- d.R
|
||||
-- d.S Force Optimize_Alignment (Space)
|
||||
|
|
@ -597,6 +597,11 @@ package body Debug is
|
|||
-- the ALI file, the internal SCO tables (SCO_Table/SCO_Unit_Table)
|
||||
-- are dumped for debugging purposes.
|
||||
|
||||
-- d.P Previous non-optimized handling of length comparisons. Setting this
|
||||
-- flag inhibits the effect of Optimize_Length_Comparison in Exp_Ch4.
|
||||
-- This is there in case we find a situation where the optimization
|
||||
-- malfunctions, to provide a work around.
|
||||
|
||||
-- d.S Force Optimize_Alignment (Space) mode as the default
|
||||
|
||||
-- d.T Force Optimize_Alignment (Time) mode as the default
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2011, 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- --
|
||||
|
|
@ -202,6 +202,12 @@ package body Exp_Ch4 is
|
|||
-- constrained type (the caller has ensured this by using
|
||||
-- Convert_To_Actual_Subtype if necessary).
|
||||
|
||||
procedure Optimize_Length_Comparison (N : Node_Id);
|
||||
-- Given an expression, if it is of the form X'Length op N (or the other
|
||||
-- way round), where N is known at compile time to be 0 or 1, and X is a
|
||||
-- simple entity, and op is a comparison operator, optimizes it into a
|
||||
-- comparison of First and Last.
|
||||
|
||||
procedure Rewrite_Comparison (N : Node_Id);
|
||||
-- If N is the node for a comparison whose outcome can be determined at
|
||||
-- compile time, then the node N can be rewritten with True or False. If
|
||||
|
|
@ -3197,9 +3203,9 @@ package body Exp_Ch4 is
|
|||
if Inside_A_Return_Statement (N)
|
||||
and then
|
||||
(Ekind (PtrT) = E_Anonymous_Access_Type
|
||||
or else
|
||||
(Ekind (PtrT) = E_Access_Type
|
||||
and then No (Associated_Final_Chain (PtrT))))
|
||||
or else
|
||||
(Ekind (PtrT) = E_Access_Type
|
||||
and then No (Associated_Final_Chain (PtrT))))
|
||||
then
|
||||
declare
|
||||
Decl : Node_Id;
|
||||
|
|
@ -6055,6 +6061,8 @@ package body Exp_Ch4 is
|
|||
Expand_Vax_Comparison (N);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Eq;
|
||||
|
||||
-----------------------
|
||||
|
|
@ -6415,6 +6423,8 @@ package body Exp_Ch4 is
|
|||
Expand_Vax_Comparison (N);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Ge;
|
||||
|
||||
--------------------
|
||||
|
|
@ -6450,6 +6460,8 @@ package body Exp_Ch4 is
|
|||
Expand_Vax_Comparison (N);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Gt;
|
||||
|
||||
--------------------
|
||||
|
|
@ -6485,6 +6497,8 @@ package body Exp_Ch4 is
|
|||
Expand_Vax_Comparison (N);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Le;
|
||||
|
||||
--------------------
|
||||
|
|
@ -6520,6 +6534,8 @@ package body Exp_Ch4 is
|
|||
Expand_Vax_Comparison (N);
|
||||
return;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Lt;
|
||||
|
||||
-----------------------
|
||||
|
|
@ -6935,6 +6951,8 @@ package body Exp_Ch4 is
|
|||
Analyze_And_Resolve (N, Standard_Boolean);
|
||||
end;
|
||||
end if;
|
||||
|
||||
Optimize_Length_Comparison (N);
|
||||
end Expand_N_Op_Ne;
|
||||
|
||||
---------------------
|
||||
|
|
@ -10157,6 +10175,397 @@ package body Exp_Ch4 is
|
|||
return Func_Body;
|
||||
end Make_Boolean_Array_Op;
|
||||
|
||||
--------------------------------
|
||||
-- Optimize_Length_Comparison --
|
||||
--------------------------------
|
||||
|
||||
procedure Optimize_Length_Comparison (N : Node_Id) is
|
||||
Loc : constant Source_Ptr := Sloc (N);
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
Result : Node_Id;
|
||||
|
||||
Left : Node_Id;
|
||||
Right : Node_Id;
|
||||
-- First and Last attribute reference nodes, which end up as left and
|
||||
-- right operands of the optimized result.
|
||||
|
||||
Is_Zero : Boolean;
|
||||
-- True for comparison operand of zero
|
||||
|
||||
Comp : Node_Id;
|
||||
-- Comparison operand, set only if Is_Zero is false
|
||||
|
||||
Ent : Entity_Id;
|
||||
-- Entity whose length is being compared
|
||||
|
||||
Index : Node_Id;
|
||||
-- Integer_Literal node for length attribute expression, or Empty
|
||||
-- if there is no such expression present.
|
||||
|
||||
Ityp : Entity_Id;
|
||||
-- Type of array index to which 'Length is applied
|
||||
|
||||
Op : Node_Kind := Nkind (N);
|
||||
-- Kind of comparison operator, gets flipped if operands backwards
|
||||
|
||||
function Is_Optimizable (N : Node_Id) return Boolean;
|
||||
-- Tests N to see if it is an optimizable comparison value (defined
|
||||
-- as constant zero or one, or something else where the value is known
|
||||
-- to be in range of 32-bits, and where the corresponding Length value
|
||||
-- is also known to be 32-bits. If result is true, sets Is_Zero, Ityp,
|
||||
-- and Comp accordingly.
|
||||
|
||||
function Is_Entity_Length (N : Node_Id) return Boolean;
|
||||
-- Tests if N is a length attribute applied to a simple entity. If so,
|
||||
-- returns True, and sets Ent to the entity, and Index to the integer
|
||||
-- literal provided as an attribute expression, or to Empty if none.
|
||||
-- Also returns True if the expression is a generated type conversion
|
||||
-- whose expression is of the desired form. This latter case arises
|
||||
-- when Apply_Universal_Integer_Attribute_Check installs a conversion
|
||||
-- to check for being in range, which is not needed in this context.
|
||||
-- Returns False if neither condition holds.
|
||||
|
||||
function Prepare_64 (N : Node_Id) return Node_Id;
|
||||
-- Given a discrete expression, returns a Long_Long_Integer typed
|
||||
-- expression representing the underlying value of the expression.
|
||||
-- This is done with an unchecked conversion to the result type. We
|
||||
-- use unchecked conversion to handle the enumeration type case.
|
||||
|
||||
----------------------
|
||||
-- Is_Entity_Length --
|
||||
----------------------
|
||||
|
||||
function Is_Entity_Length (N : Node_Id) return Boolean is
|
||||
begin
|
||||
if Nkind (N) = N_Attribute_Reference
|
||||
and then Attribute_Name (N) = Name_Length
|
||||
and then Is_Entity_Name (Prefix (N))
|
||||
then
|
||||
Ent := Entity (Prefix (N));
|
||||
|
||||
if Present (Expressions (N)) then
|
||||
Index := First (Expressions (N));
|
||||
else
|
||||
Index := Empty;
|
||||
end if;
|
||||
|
||||
return True;
|
||||
|
||||
elsif Nkind (N) = N_Type_Conversion
|
||||
and then not Comes_From_Source (N)
|
||||
then
|
||||
return Is_Entity_Length (Expression (N));
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end Is_Entity_Length;
|
||||
|
||||
--------------------
|
||||
-- Is_Optimizable --
|
||||
--------------------
|
||||
|
||||
function Is_Optimizable (N : Node_Id) return Boolean is
|
||||
Val : Uint;
|
||||
OK : Boolean;
|
||||
Lo : Uint;
|
||||
Hi : Uint;
|
||||
Indx : Node_Id;
|
||||
|
||||
begin
|
||||
if Compile_Time_Known_Value (N) then
|
||||
Val := Expr_Value (N);
|
||||
|
||||
if Val = Uint_0 then
|
||||
Is_Zero := True;
|
||||
Comp := Empty;
|
||||
return True;
|
||||
|
||||
elsif Val = Uint_1 then
|
||||
Is_Zero := False;
|
||||
Comp := Empty;
|
||||
return True;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Here we have to make sure of being within 32-bits
|
||||
|
||||
Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
|
||||
|
||||
if not OK
|
||||
or else Lo < UI_From_Int (Int'First)
|
||||
or else Hi > UI_From_Int (Int'Last)
|
||||
then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
-- Comparison value was within 32-bits, so now we must check the
|
||||
-- index value to make sure it is also within 32-bits.
|
||||
|
||||
Indx := First_Index (Etype (Ent));
|
||||
|
||||
if Present (Index) then
|
||||
for J in 2 .. UI_To_Int (Intval (Index)) loop
|
||||
Next_Index (Indx);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
Ityp := Etype (Indx);
|
||||
|
||||
if Esize (Ityp) > 32 then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
Is_Zero := False;
|
||||
Comp := N;
|
||||
return True;
|
||||
end Is_Optimizable;
|
||||
|
||||
----------------
|
||||
-- Prepare_64 --
|
||||
----------------
|
||||
|
||||
function Prepare_64 (N : Node_Id) return Node_Id is
|
||||
begin
|
||||
return Unchecked_Convert_To (Standard_Long_Long_Integer, N);
|
||||
end Prepare_64;
|
||||
|
||||
-- Start of processing for Optimize_Length_Comparison
|
||||
|
||||
begin
|
||||
-- Nothing to do if not a comparison
|
||||
|
||||
if Op not in N_Op_Compare then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Nothing to do if special -gnatd.P debug flag set
|
||||
|
||||
if Debug_Flag_Dot_PP then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Ent'Length op 0/1
|
||||
|
||||
if Is_Entity_Length (Left_Opnd (N))
|
||||
and then Is_Optimizable (Right_Opnd (N))
|
||||
then
|
||||
null;
|
||||
|
||||
-- 0/1 op Ent'Length
|
||||
|
||||
elsif Is_Entity_Length (Right_Opnd (N))
|
||||
and then Is_Optimizable (Left_Opnd (N))
|
||||
then
|
||||
-- Flip comparison to opposite sense
|
||||
|
||||
case Op is
|
||||
when N_Op_Lt => Op := N_Op_Gt;
|
||||
when N_Op_Le => Op := N_Op_Ge;
|
||||
when N_Op_Gt => Op := N_Op_Lt;
|
||||
when N_Op_Ge => Op := N_Op_Le;
|
||||
when others => null;
|
||||
end case;
|
||||
|
||||
-- Else optimization not possible
|
||||
|
||||
else
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Fall through if we will do the optimization
|
||||
|
||||
-- Cases to handle:
|
||||
|
||||
-- X'Length = 0 => X'First > X'Last
|
||||
-- X'Length = 1 => X'First = X'Last
|
||||
-- X'Length = n => X'First + (n - 1) = X'Last
|
||||
|
||||
-- X'Length /= 0 => X'First <= X'Last
|
||||
-- X'Length /= 1 => X'First /= X'Last
|
||||
-- X'Length /= n => X'First + (n - 1) /= X'Last
|
||||
|
||||
-- X'Length >= 0 => always true, warn
|
||||
-- X'Length >= 1 => X'First <= X'Last
|
||||
-- X'Length >= n => X'First + (n - 1) <= X'Last
|
||||
|
||||
-- X'Length > 0 => X'First <= X'Last
|
||||
-- X'Length > 1 => X'First < X'Last
|
||||
-- X'Length > n => X'First + (n - 1) < X'Last
|
||||
|
||||
-- X'Length <= 0 => X'First > X'Last (warn, could be =)
|
||||
-- X'Length <= 1 => X'First >= X'Last
|
||||
-- X'Length <= n => X'First + (n - 1) >= X'Last
|
||||
|
||||
-- X'Length < 0 => always false (warn)
|
||||
-- X'Length < 1 => X'First > X'Last
|
||||
-- X'Length < n => X'First + (n - 1) > X'Last
|
||||
|
||||
-- Note: for the cases of n (not constant 0,1), we require that the
|
||||
-- corresponding index type be integer or shorter (i.e. not 64-bit),
|
||||
-- and the same for the comparison value. Then we do the comparison
|
||||
-- using 64-bit arithmetic (actually long long integer), so that we
|
||||
-- cannot have overflow intefering with the result.
|
||||
|
||||
-- First deal with warning cases
|
||||
|
||||
if Is_Zero then
|
||||
case Op is
|
||||
|
||||
-- X'Length >= 0
|
||||
|
||||
when N_Op_Ge =>
|
||||
Rewrite (N,
|
||||
Convert_To (Typ, New_Occurrence_Of (Standard_True, Loc)));
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
Warn_On_Known_Condition (N);
|
||||
return;
|
||||
|
||||
-- X'Length < 0
|
||||
|
||||
when N_Op_Lt =>
|
||||
Rewrite (N,
|
||||
Convert_To (Typ, New_Occurrence_Of (Standard_False, Loc)));
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
Warn_On_Known_Condition (N);
|
||||
return;
|
||||
|
||||
when N_Op_Le =>
|
||||
if Constant_Condition_Warnings
|
||||
and then Comes_From_Source (Original_Node (N))
|
||||
then
|
||||
Error_Msg_N ("could replace by ""'=""?", N);
|
||||
end if;
|
||||
|
||||
Op := N_Op_Eq;
|
||||
|
||||
when others =>
|
||||
null;
|
||||
end case;
|
||||
end if;
|
||||
|
||||
-- Build the First reference we will use
|
||||
|
||||
Left :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent, Loc),
|
||||
Attribute_Name => Name_First);
|
||||
|
||||
if Present (Index) then
|
||||
Set_Expressions (Left, New_List (New_Copy (Index)));
|
||||
end if;
|
||||
|
||||
-- If general value case, then do the addition of (n - 1), and
|
||||
-- also add the needed conversions to type Long_Long_Integer.
|
||||
|
||||
if Present (Comp) then
|
||||
Left :=
|
||||
Make_Op_Add (Loc,
|
||||
Left_Opnd => Prepare_64 (Left),
|
||||
Right_Opnd =>
|
||||
Make_Op_Subtract (Loc,
|
||||
Left_Opnd => Prepare_64 (Comp),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1)));
|
||||
end if;
|
||||
|
||||
-- Build the Last reference we will use
|
||||
|
||||
Right :=
|
||||
Make_Attribute_Reference (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent, Loc),
|
||||
Attribute_Name => Name_Last);
|
||||
|
||||
if Present (Index) then
|
||||
Set_Expressions (Right, New_List (New_Copy (Index)));
|
||||
end if;
|
||||
|
||||
-- If general operand, convert Last reference to Long_Long_Integer
|
||||
|
||||
if Present (Comp) then
|
||||
Right := Prepare_64 (Right);
|
||||
end if;
|
||||
|
||||
-- Check for cases to optimize
|
||||
|
||||
-- X'Length = 0 => X'First > X'Last
|
||||
-- X'Length < 1 => X'First > X'Last
|
||||
-- X'Length < n => X'First + (n - 1) > X'Last
|
||||
|
||||
if (Is_Zero and then Op = N_Op_Eq)
|
||||
or else (not Is_Zero and then Op = N_Op_Lt)
|
||||
then
|
||||
Result :=
|
||||
Make_Op_Gt (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length = 1 => X'First = X'Last
|
||||
-- X'Length = n => X'First + (n - 1) = X'Last
|
||||
|
||||
elsif not Is_Zero and then Op = N_Op_Eq then
|
||||
Result :=
|
||||
Make_Op_Eq (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length /= 0 => X'First <= X'Last
|
||||
-- X'Length > 0 => X'First <= X'Last
|
||||
|
||||
elsif Is_Zero and (Op = N_Op_Ne or else Op = N_Op_Gt) then
|
||||
Result :=
|
||||
Make_Op_Le (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length /= 1 => X'First /= X'Last
|
||||
-- X'Length /= n => X'First + (n - 1) /= X'Last
|
||||
|
||||
elsif not Is_Zero and then Op = N_Op_Ne then
|
||||
Result :=
|
||||
Make_Op_Ne (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length >= 1 => X'First <= X'Last
|
||||
-- X'Length >= n => X'First + (n - 1) <= X'Last
|
||||
|
||||
elsif not Is_Zero and then Op = N_Op_Ge then
|
||||
Result :=
|
||||
Make_Op_Le (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length > 1 => X'First < X'Last
|
||||
-- X'Length > n => X'First + (n = 1) < X'Last
|
||||
|
||||
elsif not Is_Zero and then Op = N_Op_Gt then
|
||||
Result :=
|
||||
Make_Op_Lt (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- X'Length <= 1 => X'First >= X'Last
|
||||
-- X'Length <= n => X'First + (n - 1) >= X'Last
|
||||
|
||||
elsif not Is_Zero and then Op = N_Op_Le then
|
||||
Result :=
|
||||
Make_Op_Ge (Loc,
|
||||
Left_Opnd => Left,
|
||||
Right_Opnd => Right);
|
||||
|
||||
-- Should not happen at this stage
|
||||
|
||||
else
|
||||
raise Program_Error;
|
||||
end if;
|
||||
|
||||
-- Rewrite and finish up
|
||||
|
||||
Rewrite (N, Result);
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
return;
|
||||
end Optimize_Length_Comparison;
|
||||
|
||||
------------------------
|
||||
-- Rewrite_Comparison --
|
||||
------------------------
|
||||
|
|
|
|||
|
|
@ -11516,7 +11516,7 @@ package body Exp_Ch9 is
|
|||
end if;
|
||||
|
||||
-- If the type of the dispatching object is an access type then return
|
||||
-- an explicit dereference
|
||||
-- an explicit dereference.
|
||||
|
||||
if Is_Access_Type (Etype (Object)) then
|
||||
Object := Make_Explicit_Dereference (Sloc (N), Object);
|
||||
|
|
|
|||
|
|
@ -89,13 +89,23 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
|
|||
|
||||
procedure Process_Restrictions_Or_Restriction_Warnings;
|
||||
-- Common processing for Restrictions and Restriction_Warnings pragmas.
|
||||
-- This routine processes the cases of No_Obsolescent_Features and SPARK,
|
||||
-- which are the only restriction that have syntactic effects. In the case
|
||||
-- of SPARK, it controls whether the scanner generates a token
|
||||
-- Tok_SPARK_Hide for HIDE directives formatted as Ada comments. No general
|
||||
-- error checking is done, since this will be done in Sem_Prag. The other
|
||||
-- case processed is pragma Restrictions No_Dependence, since otherwise
|
||||
-- this is done too late.
|
||||
-- For the most part, restrictions need not be processed at parse time,
|
||||
-- since they only affect semantic processing. This routine handles the
|
||||
-- exceptions as follows
|
||||
--
|
||||
-- No_Obsolescent_Features must be processed at parse time, since there
|
||||
-- are some obsolescent features (e.g. character replacements) which are
|
||||
-- handled at parse time.
|
||||
--
|
||||
-- SPARK must be processed at parse time, since this restriction controls
|
||||
-- whether the scanner recognizes a spark HIDE directive formatted as an
|
||||
-- Ada comment (and generates a Tok_SPARK_Hide token for the directive).
|
||||
--
|
||||
-- No_Dependence must be processed at parse time, since otherwise it gets
|
||||
-- handled too late.
|
||||
--
|
||||
-- Note that we don't need to do full error checking for badly formed cases
|
||||
-- of restrictions, since these will be caught during semantic analysis.
|
||||
|
||||
----------
|
||||
-- Arg1 --
|
||||
|
|
@ -232,10 +242,12 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
|
|||
Set_Restriction (No_Obsolescent_Features, Pragma_Node);
|
||||
Restriction_Warnings (No_Obsolescent_Features) :=
|
||||
Prag_Id = Pragma_Restriction_Warnings;
|
||||
|
||||
when SPARK =>
|
||||
Set_Restriction (SPARK, Pragma_Node);
|
||||
Restriction_Warnings (SPARK) :=
|
||||
Prag_Id = Pragma_Restriction_Warnings;
|
||||
|
||||
when others =>
|
||||
null;
|
||||
end case;
|
||||
|
|
|
|||
|
|
@ -178,9 +178,9 @@ package Restrict is
|
|||
-- SPARK Restriction Control --
|
||||
-------------------------------
|
||||
|
||||
-- SPARK HIDE directives allow turning off SPARK restriction for a
|
||||
-- specified region of code, and the following tables are the data
|
||||
-- structures used to keep track of these regions.
|
||||
-- SPARK HIDE directives allow the effect of the SPARK restriction to be
|
||||
-- turned off for a specified region of code, and the following tables are
|
||||
-- the data structures used to keep track of these regions.
|
||||
|
||||
-- The table contains pairs of source locations, the first being the start
|
||||
-- location for hidden region, and the second being the end location.
|
||||
|
|
|
|||
|
|
@ -1764,8 +1764,8 @@ package body Scng is
|
|||
return;
|
||||
end if;
|
||||
|
||||
-- Generate a token Tok_SPARK_Hide for a SPARK HIDE directive
|
||||
-- only if the SPARK restriction is set for this unit.
|
||||
-- If the SPARK restriction is set for this unit, then generate
|
||||
-- a token Tok_SPARK_Hide for a SPARK HIDE directive.
|
||||
|
||||
if Restriction_Check_Required (SPARK)
|
||||
and then Source (Start_Of_Comment) = '#'
|
||||
|
|
|
|||
|
|
@ -2335,6 +2335,7 @@ package body Sem_Util is
|
|||
|
||||
procedure Mark_Non_ALFA_Subprogram_Unconditional is
|
||||
Cur_Subp : constant Entity_Id := Current_Subprogram;
|
||||
|
||||
begin
|
||||
if Present (Cur_Subp)
|
||||
and then (Is_Subprogram (Cur_Subp)
|
||||
|
|
@ -2344,6 +2345,9 @@ package body Sem_Util is
|
|||
-- then mark the subprogram as not in ALFA. Otherwise, mark the
|
||||
-- subprogram body as not in ALFA.
|
||||
|
||||
-- This comment just says what is done, but not why ??? and it
|
||||
-- just repeats what is in the spec ???
|
||||
|
||||
if In_Pre_Post_Expression then
|
||||
Set_Is_In_ALFA (Cur_Subp, False);
|
||||
else
|
||||
|
|
|
|||
|
|
@ -279,10 +279,14 @@ package Sem_Util is
|
|||
|
||||
procedure Mark_Non_ALFA_Subprogram;
|
||||
-- If Current_Subprogram is not Empty, mark either its specification or its
|
||||
-- body as not being in ALFA. If called during the analysis of a
|
||||
-- precondition or postcondition, as indicated by the flag
|
||||
-- body as not being in ALFA. If this procedure is called during the
|
||||
-- analysis of a precondition or postcondition, as indicated by the flag
|
||||
-- In_Pre_Post_Expression, mark the specification as not being in ALFA.
|
||||
-- Otherwise, mark the body as not being in ALFA.
|
||||
--
|
||||
-- I would really like to see more comments on this peculiar processing
|
||||
-- for precondition/postcondition, the comment above says what is done
|
||||
-- but not why???
|
||||
|
||||
function Defining_Entity (N : Node_Id) return Entity_Id;
|
||||
-- Given a declaration N, returns the associated defining entity. If the
|
||||
|
|
|
|||
|
|
@ -1116,7 +1116,7 @@ package Sinfo is
|
|||
-- this is required, see Exp_Ch11.Remove_Handler_Entries.
|
||||
|
||||
-- Has_Dynamic_Length_Check (Flag10-Sem)
|
||||
-- This flag is present on all expression nodes. It is set to indicate
|
||||
-- This flag is present in all expression nodes. It is set to indicate
|
||||
-- that one of the routines in unit Checks has generated a length check
|
||||
-- action which has been inserted at the flagged node. This is used to
|
||||
-- avoid the generation of duplicate checks.
|
||||
|
|
@ -1126,7 +1126,8 @@ package Sinfo is
|
|||
-- expression nodes. It is set to indicate that one of the routines in
|
||||
-- unit Checks has generated a range check action which has been inserted
|
||||
-- at the flagged node. This is used to avoid the generation of duplicate
|
||||
-- checks.
|
||||
-- checks. Why does this occur on N_Subtype_Declaration nodes, what does
|
||||
-- it mean in that context???
|
||||
|
||||
-- Has_Local_Raise (Flag8-Sem)
|
||||
-- Present in exception handler nodes. Set if the handler can be entered
|
||||
|
|
|
|||
Loading…
Reference in New Issue