attr->executable = (!ret && (statbuf.st_mode & S_IXUSR));
#endif
-#if !defined (_WIN32) || defined (RTX)
- /* on Windows requires extra system call, see __gnat_file_time_name_attr */
if (ret != 0) {
attr->timestamp = (OS_Time)-1;
} else {
attr->timestamp = (OS_Time)statbuf.st_mtime;
#endif
}
-#endif
-
}
/****************************************************************
return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
return (time_t) 0;
}
+
+/* As above but starting from a FILETIME. */
+static void f2t (const FILETIME *ft, time_t *t)
+{
+ union
+ {
+ FILETIME ft_time;
+ unsigned long long ull_time;
+ } t_write;
+
+ t_write.ft_time = *ft;
+ *t = (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
+}
#endif
/* Return a GNAT time stamp given a file name. */
__gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
{
#ifdef __MINGW32__
- /* Under Windows the directory name for the stat function must not be
- terminated by a directory separator except if just after a drive name
- or with UNC path without directory (only the name of the shared
- resource), for example: \\computer\share\ */
-
+ WIN32_FILE_ATTRIBUTE_DATA fad;
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
- int name_len, k;
- TCHAR last_char;
- int dirsep_count = 0;
+ int name_len;
+ BOOL res;
S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
name_len = _tcslen (wname);
if (name_len > GNAT_MAX_PATH_LEN)
return -1;
- last_char = wname[name_len - 1];
-
- while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
- {
- wname[name_len - 1] = _T('\0');
- name_len--;
- last_char = wname[name_len - 1];
+ ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
+
+ res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad);
+
+ if (res == FALSE)
+ switch (GetLastError()) {
+ case ERROR_ACCESS_DENIED:
+ case ERROR_SHARING_VIOLATION:
+ case ERROR_LOCK_VIOLATION:
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ return EACCES;
+ case ERROR_BUFFER_OVERFLOW:
+ return ENAMETOOLONG;
+ case ERROR_NOT_ENOUGH_MEMORY:
+ return ENOMEM;
+ default:
+ return ENOENT;
}
- /* Count back-slashes. */
+ f2t (&fad.ftCreationTime, &statbuf->st_ctime);
+ f2t (&fad.ftLastWriteTime, &statbuf->st_mtime);
+ f2t (&fad.ftLastAccessTime, &statbuf->st_atime);
+
+ statbuf->st_size = (off_t)fad.nFileSizeLow;
- for (k=0; k<name_len; k++)
- if (wname[k] == _T('\\') || wname[k] == _T('/'))
- dirsep_count++;
+ /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */
+ statbuf->st_mode = S_IREAD;
- /* Only a drive letter followed by ':', we must add a directory separator
- for the stat routine to work properly. */
- if ((name_len == 2 && wname[1] == _T(':'))
- || (name_len > 3 && wname[0] == _T('\\') && wname[1] == _T('\\')
- && dirsep_count == 3))
- _tcscat (wname, _T("\\"));
+ if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
+ statbuf->st_mode |= S_IFDIR;
+ else
+ statbuf->st_mode |= S_IFREG;
- return _tstat (wname, (struct _stat *)statbuf);
+ if (!(fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
+ statbuf->st_mode |= S_IWRITE;
+
+ return 0;
#else
return GNAT_STAT (name, statbuf);
(Typ : Entity_Id;
Expr : Node_Id;
Nam : Name_Id);
- -- Given a predicated type Typ, whose predicate expression is Expr, tests
- -- if Expr is a static predicate, and if so, builds the predicate range
- -- list. Nam is the name of the argument to the predicate function.
- -- Occurrences of the type name in the predicate expression have been
- -- replaced by identifer references to this name, which is unique, so any
- -- identifier with Chars matching Nam must be a reference to the type. If
- -- the predicate is non-static, this procedure returns doing nothing. If
- -- the predicate is static, then the corresponding predicate list is stored
- -- in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized
- -- membership operation.
+ -- Given a predicated type Typ, where Typ is a discrete static subtype,
+ -- whose predicate expression is Expr, tests if Expr is a static predicate,
+ -- and if so, builds the predicate range list. Nam is the name of the one
+ -- argument to the predicate function. Occurrences of the type name in the
+ -- predicate expression have been replaced by identifer references to this
+ -- name, which is unique, so any identifier with Chars matching Nam must be
+ -- a reference to the type. If the predicate is non-static, this procedure
+ -- returns doing nothing. If the predicate is static, then the predicate
+ -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
+ -- a canonicalized membership operation.
function Get_Alignment_Value (Expr : Node_Id) return Uint;
-- Given the expression for an alignment value, returns the corresponding
-- Deal with static predicate case
- Build_Static_Predicate (Typ, Expr, Object_Name);
+ if Ekind_In (Typ, E_Enumeration_Subtype,
+ E_Modular_Integer_Subtype,
+ E_Signed_Integer_Subtype)
+ and then Is_Static_Subtype (Typ)
+ then
+ Build_Static_Predicate (Typ, Expr, Object_Name);
+ end if;
-- Build function declaration
Non_Static : exception;
-- Raised if something non-static is found
- TLo, THi : Uint;
- -- Low bound and high bound values of static subtype of Typ
+ Btyp : constant Entity_Id := Base_Type (Typ);
+
+ BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp));
+ BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
+ -- Low bound and high bound value of base type of Typ
+
+ TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
+ THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
+ -- Low bound and high bound values of static subtype Typ
type REnt is record
Lo, Hi : Uint;
type RList is array (Nat range <>) of REnt;
-- A list of ranges. The ranges are sorted in increasing order,
-- and are disjoint (there is a gap of at least one value between
- -- each range in the table).
+ -- each range in the table). A value is in the set of ranges in
+ -- Rlist if it lies within one of these ranges
- Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
- True_Range : RList renames Null_Range;
- -- Constant representing null list of ranges, used to represent a
- -- predicate of True, since there are no ranges to be satisfied.
+ False_Range : constant RList :=
+ RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+ -- An empty set of ranges represents a range list that can never be
+ -- satisfied, since there are no ranges in which the value could lie,
+ -- so it does not lie in any of them. False_Range is a canonical value
+ -- for this empty set, but general processing should test for an Rlist
+ -- with length zero (see Is_False predicate), since other null ranges
+ -- may appear which must be treated as False.
- False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0));
- -- Range representing false
+ True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
+ -- Range representing True, value must be in the base range
function "and" (Left, Right : RList) return RList;
-- And's together two range lists, returning a range list. This is
function Build_Val (V : Uint) return Node_Id;
-- Return an analyzed N_Identifier node referencing this value, suitable
- -- for use as an entry in the Static_Predicate list.
+ -- for use as an entry in the Static_Predicate list. This node is typed
+ -- with the base type.
function Build_Range (Lo, Hi : Uint) return Node_Id;
-- Return an analyzed N_Range node referencing this range, suitable
- -- for use as an entry in the Static_Predicate list.
+ -- for use as an entry in the Static_Predicate list. This node is typed
+ -- with the base type.
function Get_RList (Exp : Node_Id) return RList;
-- This is a recursive routine that converts the given expression into
-- a list of ranges, suitable for use in building the static predicate.
+ function Is_False (R : RList) return Boolean;
+ pragma Inline (Is_False);
+ -- Returns True if the given range list is empty, and thus represents
+ -- a False list of ranges that can never be satsified.
+
+ function Is_True (R : RList) return Boolean;
+ -- Returns True if R trivially represents the True predicate by having
+ -- a single range from BLo to BHi.
+
function Is_Type_Ref (N : Node_Id) return Boolean;
pragma Inline (Is_Type_Ref);
-- Returns if True if N is a reference to the type for the predicate in
begin
-- If either range is True, return the other
- if Left = True_Range then
+ if Is_True (Left) then
return Right;
- elsif Right = True_Range then
+ elsif Is_True (Right) then
return Left;
end if;
-- If either range is False, return False
- if Left = False_Range or else Right = False_Range then
- return False_Range;
- end if;
-
- -- If either range is empty, return False
-
- if Left'Length = 0 or else Right'Length = 0 then
+ if Is_False (Left) or else Is_False (Right) then
return False_Range;
end if;
SRight := SRight + 1;
end if;
- -- If either operand is empty, that's the only entry
+ -- Compute result by concatenating this first entry with the "and"
+ -- of the remaining parts of the left and right operands. Note that
+ -- if either of these is empty, "and" will yield empty, so that we
+ -- will end up with just Fent, which is what we want in that case.
- if SLeft > Left'Last or else SRight > Right'Last then
- return RList'(1 => FEnt);
-
- -- Else compute and of remaining entries and concatenate
-
- else
- return
- FEnt &
- (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
- end if;
+ return
+ FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
end "and";
-----------
begin
-- Return True if False range
- if Right = False_Range then
+ if Is_False (Right) then
return True_Range;
end if;
-- Return False if True range
- if Right'Length = 0 then
+ if Is_True (Right) then
return False_Range;
end if;
----------
function "or" (Left, Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
+
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
+
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
+
begin
-- If either range is True, return True
- if Left = True_Range or else Right = True_Range then
+ if Is_True (Left) or else Is_True (Right) then
return True_Range;
end if;
- -- If either range is False, return the other
+ -- If either range is False (empty), return the other
- if Left = False_Range then
+ if Is_False (Left) then
return Right;
- elsif Right = False_Range then
+ elsif Is_False (Right) then
return Left;
end if;
- -- If either operand is null, return the other one
+ -- Initialize result first entry from left or right operand
+ -- depending on which starts with the lower range.
- if Left'Length = 0 then
- return Right;
- elsif Right'Length = 0 then
- return Left;
+ if Left (SLeft).Lo < Right (SRight).Lo then
+ FEnt := Left (SLeft);
+ SLeft := SLeft + 1;
+ else
+ FEnt := Right (SRight);
+ SRight := SRight + 1;
end if;
- -- Now we have two non-null ranges
-
- declare
- FEnt : REnt;
- -- First range of result
-
- SLeft : Nat := Left'First;
- -- Start of rest of left entries
+ -- This loop eats ranges from left and right operands that
+ -- are contiguous with the first range we are gathering.
- SRight : Nat := Right'First;
- -- Start of rest of right entries
-
- begin
- -- Initialize result first entry from left or right operand
- -- depending on which starts with the lower range.
+ loop
+ -- Eat first entry in left operand if contiguous or
+ -- overlapped by gathered first operand of result.
- if Left (SLeft).Lo < Right (SRight).Lo then
- FEnt := Left (SLeft);
+ if SLeft <= Left'Last
+ and then Left (SLeft).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
SLeft := SLeft + 1;
- else
- FEnt := Right (SRight);
- SRight := SRight + 1;
- end if;
-
- -- This loop eats ranges from left and right operands that
- -- are contiguous with the first range we are gathering.
-
- loop
- -- Eat first entry in left operand if contiguous or
- -- overlapped by gathered first operand of result.
-
- if SLeft <= Left'Last
- and then Left (SLeft).Lo <= FEnt.Hi + 1
- then
- FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
- SLeft := SLeft + 1;
-- Eat first entry in right operand if contiguous or
-- overlapped by gathered right operand of result.
- elsif SRight <= Right'Last
- and then Right (SRight).Lo <= FEnt.Hi + 1
- then
- FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
- SRight := SRight + 1;
+ elsif SRight <= Right'Last
+ and then Right (SRight).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+ SRight := SRight + 1;
-- All done if no more entries to eat!
- else
- exit;
- end if;
- end loop;
-
- -- If left operand now empty, concatenate our new entry to right
-
- if SLeft > Left'Last then
- return FEnt & Right (SRight .. Right'Last);
-
- -- If right operand now empty, concatenate our new entry to left
-
- elsif SRight > Right'Last then
- return FEnt & Left (SLeft .. Left'Last);
-
- -- Otherwise, compute or of what is left and concatenate
-
else
- return
- FEnt &
- (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+ exit;
end if;
- end;
+ end loop;
+
+ -- Obtain result as the first entry we just computed, concatenated
+ -- to the "or" of the remaining results (if one operand is empty,
+ -- this will just concatenate with the other
+
+ return
+ FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
end "or";
-----------------
Make_Range (Loc,
Low_Bound => Build_Val (Lo),
High_Bound => Build_Val (Hi));
- Set_Etype (Result, Typ);
+ Set_Etype (Result, Btyp);
Set_Analyzed (Result);
return Result;
end if;
Result := Make_Integer_Literal (Loc, Intval => V);
end if;
- Set_Etype (Result, Typ);
+ Set_Etype (Result, Btyp);
Set_Is_Static_Expression (Result);
Set_Analyzed (Result);
return Result;
if Is_OK_Static_Expression (Exp) then
- -- For False, return impossible range, which will always fail
+ -- For False
if Expr_Value (Exp) = 0 then
return False_Range;
-
- -- For True, null range
-
else
- return Null_Range;
+ return True_Range;
end if;
end if;
return RList'(1 => REnt'(Val, Val));
when N_Op_Ge =>
- return RList'(1 => REnt'(Val, THi));
+ return RList'(1 => REnt'(Val, BHi));
when N_Op_Gt =>
- return RList'(1 => REnt'(Val + 1, THi));
+ return RList'(1 => REnt'(Val + 1, BHi));
when N_Op_Le =>
- return RList'(1 => REnt'(TLo, Val));
+ return RList'(1 => REnt'(BLo, Val));
when N_Op_Lt =>
- return RList'(1 => REnt'(TLo, Val - 1));
+ return RList'(1 => REnt'(BLo, Val - 1));
when N_Op_Ne =>
- return RList'(REnt'(TLo, Val - 1),
- REnt'(Val + 1, THi));
+ return RList'(REnt'(BLo, Val - 1),
+ REnt'(Val + 1, BHi));
when others =>
raise Program_Error;
when N_Qualified_Expression =>
return Get_RList (Expression (Exp));
+ -- Xor operator
+
+ when N_Op_Xor =>
+ return (Get_RList (Left_Opnd (Exp))
+ and not Get_RList (Right_Opnd (Exp)))
+ or (Get_RList (Right_Opnd (Exp))
+ and not Get_RList (Left_Opnd (Exp)));
+
-- Any other node type is non-static
when others =>
end if;
end Hi_Val;
+ --------------
+ -- Is_False --
+ --------------
+
+ function Is_False (R : RList) return Boolean is
+ begin
+ return R'Length = 0;
+ end Is_False;
+
+ -------------
+ -- Is_True --
+ -------------
+
+ function Is_True (R : RList) return Boolean is
+ begin
+ return R'Length = 1
+ and then R (R'First).Lo = BLo
+ and then R (R'First).Hi = BHi;
+ end Is_True;
+
-----------------
-- Is_Type_Ref --
-----------------
-- Start of processing for Build_Static_Predicate
begin
- -- Immediately non-static if our subtype is non static, or we
- -- do not have an appropriate discrete subtype in the first place.
-
- if not Ekind_In (Typ, E_Enumeration_Subtype,
- E_Modular_Integer_Subtype,
- E_Signed_Integer_Subtype)
- or else not Is_Static_Subtype (Typ)
- then
- return;
- end if;
-
- -- Get bounds of the type
-
- TLo := Expr_Value (Type_Low_Bound (Typ));
- THi := Expr_Value (Type_High_Bound (Typ));
-
-- Now analyze the expression to see if it is a static predicate
declare
-- Ranges array, we just have raw ranges, these must be converted
-- to properly typed and analyzed static expressions or range nodes.
+ -- Note: here we limit ranges to the ranges of the subtype, so that
+ -- a predicate is always false for values outside the subtype. That
+ -- seems fine, such values are invalid anyway, and considering them
+ -- to fail the predicate seems allowed and friendly, and furthermore
+ -- simplifies processing for case statements and loops.
+
Plist := New_List;
for J in Ranges'Range loop
declare
- Lo : constant Uint := Ranges (J).Lo;
- Hi : constant Uint := Ranges (J).Hi;
+ Lo : Uint := Ranges (J).Lo;
+ Hi : Uint := Ranges (J).Hi;
begin
- if Lo = Hi then
- Append_To (Plist, Build_Val (Lo));
+ -- Ignore completely out of range entry
+
+ if Hi < TLo or else Lo > THi then
+ null;
+
+ -- Otherwise process entry
+
else
- Append_To (Plist, Build_Range (Lo, Hi));
+ -- Adjust out of range value to subtype range
+
+ if Lo < TLo then
+ Lo := TLo;
+ end if;
+
+ if Hi > THi then
+ Hi := THi;
+ end if;
+
+ -- Convert range into required form
+
+ if Lo = Hi then
+ Append_To (Plist, Build_Val (Lo));
+ else
+ Append_To (Plist, Build_Range (Lo, Hi));
+ end if;
end if;
end;
end loop;
Next (Old_Node);
end loop;
- -- If empty list, replace by True
+ -- If empty list, replace by False
if Is_Empty_List (New_Alts) then
- Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc));
-
- -- If singleton list, replace by simple membership test
-
- elsif List_Length (New_Alts) = 1 then
- Rewrite (Expr,
- Make_In (Loc,
- Left_Opnd => Make_Identifier (Loc, Nam),
- Right_Opnd => Relocate_Node (First (New_Alts)),
- Alternatives => No_List));
+ Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
- -- If more than one range, replace by set membership test
+ -- Else replace by set membership test
else
Rewrite (Expr,
projects / platform / upstream / linaro-gcc.git / commitdiff